「▲VBA」の編集履歴(バックアップ)一覧はこちら
「▲VBA」(2011/02/24 (木) 15:17:25) の最新版変更点
追加された行は緑色になります。
削除された行は赤色になります。
******************************************
EXCEL の xlsファイル フォーマット 解除
******************************************
●セルの結合を解除して同じ値を入力
Sub セルの結合を解除して同じ値を入力()
Dim mydate As String
i = 4
Do While i < 30
Cells(4, i).Activate
Do Until ActiveCell = ""
mydate = ActiveCell.Value
If ActiveCell.MergeCells Then
ActiveCell.UnMerge
Selection.Value = mydate
Else
ActiveCell.Offset(1).Activate
End If
Loop
i = i + 1
Loop
End Sub
*********************************************************
EXCEL のデータから txtファイルへ出力する。
*********************************************************
Option Explicit
' テキストファイル書き出すサンプル
Sub WRITE_TextFile()
Const cnsTITLE = "テキストファイル出力処理"
Const cnsFILTER = "テキストファイル (*.txt;*.dat),*.txt;*.dat"
Dim xlAPP As Application ' Applicationオブジェクト
Dim intFF As Integer ' FreeFile値
Dim strFILENAME As String ' OPENするファイル名(フルパス)
Dim strREC As String ' 書き出すレコード内容
Dim Retu As Long
Dim GYO As Long ' 収容するセルの行
Dim MaxRow As Long ' データが収容された最終行
Dim MaxCol As Long
Dim lngREC As Long ' レコード件数カウンタ
' Applicationオブジェクト取得
Set xlAPP = Application
' 「名前を付けて保存」のフォームでファイル名の指定を受ける
xlAPP.StatusBar = "出力するファイル名を指定して下さい。" ' ①
strFILENAME = xlAPP.GetSaveAsFilename(InitialFileName:=ActiveSheet.Name & ".sql", _
FileFilter:=cnsFILTER, Title:=cnsTITLE)
' キャンセルされた場合は以降の処理は行なわない
If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
With ActiveSheet.UsedRange
MaxRow = .Rows.Count
MaxCol = .Columns.Count
End With
' MaxRow = Cells.SpecialCells(xlCellTypeLastCell).Row ' ②
Do While Cells(MaxRow, 1).Value = "" ' ③
MaxRow = MaxRow - 1
Loop
If MaxRow < 2 Then
xlAPP.StatusBar = False
MsgBox "テキストをA列2行目から入力してから起動して下さい。", , cnsTITLE
Exit Sub
End If
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(出力モード)
Open strFILENAME For Output As #intFF ' ④
' 2行目から開始
GYO = 2
' 最終行まで繰り返す
Do Until GYO > MaxRow
' A列内容をレコードにセット(先頭は2行目)
Retu = 1
strREC = ""
Do Until Retu > MaxCol
strREC = strREC & Cells(GYO, Retu).Value
Retu = Retu + 1
Loop
' レコードを出力
Print #intFF, strREC ' ⑥
' レコード件数カウンタの加算
lngREC = lngREC + 1
xlAPP.StatusBar = "出力中です....(" & lngREC & "レコード目)"
' 行を加算
GYO = GYO + 1
Loop
' 指定ファイルをCLOSE
Close #intFF
xlAPP.StatusBar = False
' 終了の表示
MsgBox "ファイル出力が完了しました。" & vbCr & _
"レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub
***********************************************************************************
******************************************
EXCEL の xlsファイル フォーマット 解除
******************************************
●セルの結合を解除して同じ値を入力
Sub セルの結合を解除して同じ値を入力()
Dim mydate As String
i = 4
Do While i < 30
Cells(4, i).Activate
Do Until ActiveCell = ""
mydate = ActiveCell.Value
If ActiveCell.MergeCells Then
ActiveCell.UnMerge
Selection.Value = mydate
Else
ActiveCell.Offset(1).Activate
End If
Loop
i = i + 1
Loop
End Sub
*********************************************************
EXCEL のデータから txtファイルへ出力する。
*********************************************************
Option Explicit
' テキストファイル書き出すサンプル
Sub WRITE_TextFile()
Const cnsTITLE = "テキストファイル出力処理"
Const cnsFILTER = "テキストファイル (*.txt;*.dat),*.txt;*.dat"
Dim xlAPP As Application ' Applicationオブジェクト
Dim intFF As Integer ' FreeFile値
Dim strFILENAME As String ' OPENするファイル名(フルパス)
Dim strREC As String ' 書き出すレコード内容
Dim Retu As Long
Dim GYO As Long ' 収容するセルの行
Dim MaxRow As Long ' データが収容された最終行
Dim MaxCol As Long
Dim lngREC As Long ' レコード件数カウンタ
' Applicationオブジェクト取得
Set xlAPP = Application
' 「名前を付けて保存」のフォームでファイル名の指定を受ける
xlAPP.StatusBar = "出力するファイル名を指定して下さい。" ' ①
strFILENAME = xlAPP.GetSaveAsFilename(InitialFileName:=ActiveSheet.Name & ".sql", _
FileFilter:=cnsFILTER, Title:=cnsTITLE)
' キャンセルされた場合は以降の処理は行なわない
If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
'入力範囲の行列を取得する。
With ActiveSheet.UsedRange
MaxRow = .Rows.Count
MaxCol = .Columns.Count
End With
' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
' MaxRow = Cells.SpecialCells(xlCellTypeLastCell).Row ' ②
Do While Cells(MaxRow, 1).Value = "" ' ③
MaxRow = MaxRow - 1
Loop
If MaxRow < 2 Then
xlAPP.StatusBar = False
MsgBox "テキストをA列2行目から入力してから起動して下さい。", , cnsTITLE
Exit Sub
End If
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(出力モード)
Open strFILENAME For Output As #intFF ' ④
' 2行目から開始
GYO = 2
' 最終行まで繰り返す
Do Until GYO > MaxRow
' A列内容をレコードにセット(先頭は2行目)
Retu = 1
strREC = ""
Do Until Retu > MaxCol
strREC = strREC & Cells(GYO, Retu).Value
Retu = Retu + 1
Loop
' レコードを出力
Print #intFF, strREC ' ⑥
' レコード件数カウンタの加算
lngREC = lngREC + 1
xlAPP.StatusBar = "出力中です....(" & lngREC & "レコード目)"
' 行を加算
GYO = GYO + 1
Loop
' 指定ファイルをCLOSE
Close #intFF
xlAPP.StatusBar = False
' 終了の表示
MsgBox "ファイル出力が完了しました。" & vbCr & _
"レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub
***********************************************************************************