Sub MergeCSVFiles4()
'フォルダのパスを指定
'ユーザーにCSVファイルが格納されたフォルダを選択してもらう
MsgBox "データをまとめるCSVファイルが格納されているフォルダを選択してください", vbOKOnly
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "フォルダが選択されていません。", vbCritical
Exit Sub
Else
folderPath = .SelectedItems(1)
End If
End With
'データをまとめるエクセルシートの作成
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add
'CSVファイルの検索
Dim fileSystem As Object
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Dim folder As Object
Set folder = fileSystem.GetFolder(folderPath)
Dim file As Object
Dim lastRow As Long
Dim fileName As String
Dim csvData As String
Dim csvRow() As String
'CSVファイルのデータを貼り付ける位置
Dim pasteCell As Range
Set pasteCell = ThisWorkbook.Sheets(1).Range("C1")
For Each file In folder.Files
If Right(file.Name, 4) = ".csv" Then
'CSVファイルを開く
Open file.Path For Input As #1
'CSVファイルのデータをエクセルシートに書き込む
fileName = Replace(file.Name, ".csv", "")
createDate = Format(fileSystem.GetFile(file.Path).DateCreated, "yyyy/mm/dd hh:mm:ss")
While Not EOF(1)
Line Input #1, csvData
csvRow = Split(csvData, ",")
pasteCell.Value = fileName
pasteCell.Offset(0, 1).Value = csvRow(0)
pasteCell.Offset(0, 2).Value = csvRow(1)
pasteCell.Offset(0, 3).Value = csvRow(2)
pasteCell.Offset(0, 4).Value = csvRow(3)
pasteCell.Offset(0, 5).Value = createDate
Set pasteCell = pasteCell.Offset(1, 0)
Wend
'CSVファイルを閉じる
Close #1
End If
Next file
'データを日時順に並び替える
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:F" & ws
■
'CSVファイルを開く
Open file.Path For Input As #1
'CSVファイルのデータをエクセルシートに書き込む
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
fileName = Replace(file.Name, ".csv", "")
createDate = Format(fileSystem.GetFile(file.Path).DateCreated, "yyyy/mm/dd hh:mm:ss")
Line Input #1, csvData '1行目のデータを読み込む
csvRow = Split(csvData, ",")
ws.Range("A1:F1").Value = Array(fileName, csvRow(0), csvRow(1), csvRow(2), csvRow(3), createDate)
'2行目以降のデータを処理しないため、Whileループを終了
Exit While
欠番とシートを分離別エクセルに名前をつけて保存する
Sub ExtractMissingNumbers欠番検索()
Dim rng As Range
Dim i As Long, lastRow As Long
Dim missingNumbers As String
'処理するセル範囲を設定
Set rng = Range("A1:A10000") '実際のセル範囲に合わせて変更してください
'最終行を取得
lastRow = rng.Cells(rng.Cells.Count).row
'欠番を検索
For i = 1 To lastRow - 1
If rng.Cells(i + 1, 1).Value - rng.Cells(i, 1).Value > 1 Then
missingNumbers = missingNumbers & _
Join(Application.Transpose(Evaluate("ROW(" & _
rng.Cells(i, 1).Value + 1 & ":" & _
rng.Cells(i + 1, 1).Value - 1 & ")")), ",") & ","
End If
Next i
'最後のカンマを削除
If Len(missingNumbers) > 0 Then
missingNumbers = Left(missingNumbers, Len(missingNumbers) - 1)
End If
'欠番を出力
MsgBox missingNumbers
Range("B1").Value = ("欠番:") & missingNumbers
End Sub
Sub SaveSheetAsNewFile()
Dim sht As Worksheet
Set sht = ActiveSheet
'保存先フォルダのパスを取得
Dim savePath As String
savePath = Range("A2").Value
'保存するファイル名を取得
Dim saveFileName As String
saveFileName = Range("A4").Value
'ファイル名が".xlsx"で終わっていない場合は追加する
If Right(saveFileName, 5) <> ".xlsx" Then
saveFileName = saveFileName & ".xlsx"
End If
'現在のシートを新しいブックにコピーする
sht.Copy
Dim newWorkbook As Workbook
Set newWorkbook = ActiveWorkbook
'新しいブックを指定のパスに保存する
Application.DisplayAlerts = False '上書き保存の確認をしない
newWorkbook.SaveAs fileName:=savePath & "\" & saveFileName, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'新しいブックを閉じる
newWorkbook.Close
'元のファイル上のシートを削除する
Application.DisplayAlerts = False '削除の確認をしない
sht.Delete
Application.DisplayAlerts = True
End Sub
欠番を検索するマクロ ほぼchatgptで書いてもらってます
Sub ExtractMissingNumbers欠番検索()
Dim rng As Range
Dim i As Long, lastRow As Long
Dim missingNumbers As String
'処理するセル範囲を設定
Set rng = Range("A1:A10000") '実際のセル範囲に合わせて変更してください
'最終行を取得
lastRow = rng.Cells(rng.Cells.Count).Row
'欠番を検索
For i = 1 To lastRow - 1
If rng.Cells(i + 1, 1).Value - rng.Cells(i, 1).Value > 1 Then
missingNumbers = missingNumbers & _
Join(Application.Transpose(Evaluate("ROW(" & _
rng.Cells(i, 1).Value + 1 & ":" & _
rng.Cells(i + 1, 1).Value - 1 & ")")), ",") & ","
End If
Next i
'最後のカンマを削除
If Len(missingNumbers) > 0 Then
missingNumbers = Left(missingNumbers, Len(missingNumbers) - 1)
End If
'欠番を出力
MsgBox missingNumbers
Range("B1").Value = ("欠番:") & missingNumbers
End Sub
Sub MergeCSVFiles4()
Sub MergeCSVFiles4()
'フォルダのパスを指定
'ユーザーにCSVファイルが格納されたフォルダを選択してもらう
MsgBox "データをまとめるCSVファイルが格納されているフォルダを選択してください", vbOKOnly
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "フォルダが選択されていません。", vbCritical
Exit Sub
Else
folderPath = .SelectedItems(1)
End If
End With
'データをまとめるエクセルシートの作成
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add
'CSVファイルの検索
Dim fileSystem As Object
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Dim folder As Object
Set folder = fileSystem.GetFolder(folderPath)
Dim file As Object
Dim lastRow As Long
Dim fileName As String
Dim csvData As String
Dim csvRow() As String
For Each file In folder.Files
If Right(file.Name, 4) = ".csv" Then
'CSVファイルを開く
Open file.Path For Input As #1
'CSVファイルのデータをエクセルシートに書き込む
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
fileName = Replace(file.Name, ".csv", "")
createDate = Format(fileSystem.GetFile(file.Path).DateCreated, "yyyy/mm/dd hh:mm:ss")
While Not EOF(1)
Line Input #1, csvData
csvRow = Split(csvData, ",")
ws.Cells(lastRow + 1, 1).Value = fileName
ws.Cells(lastRow + 1, 2).Value = csvRow(0)
ws.Cells(lastRow + 1, 3).Value = csvRow(1)
ws.Cells(lastRow + 1, 4).Value = csvRow(2)
ws.Cells(lastRow + 1, 5).Value = csvRow(3)
ws.Cells(lastRow + 1, 6).Value = createDate
lastRow = lastRow + 1
Wend
'CSVファイルを閉じる
Close #1
End If
Next file
End Sub
Sub 先頭行削除_日時順に並び変え()
'
' 先頭行削除_日時順に並び変え Macro
'
'
Columns("A:F").Select
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add2 Key:=Range("F:F") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range("A:F")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
