▲VBA

「▲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 ***********************************************************************************

表示オプション

横に並べて表示:
変化行の前後のみ表示: