Sub WriteToExcel()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim i As Long
'①
Set wb = Workbooks.Open(Filename:="ポイント情報照会.csv")
Set ws = wb.Sheets(1)
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'フィルターを設定
ws.Range("A1:D" & lastRow).AutoFilter Field:=1, Criteria1:="httpstatus200"
Set rng = ws.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible)
'結果を新しいExcelブックにコピー
Dim newWb As Workbook
Set newWb = Workbooks.Add
Set ws = newWb.Sheets(1)
rng.Copy ws.Range("A1")
'ブックを保存
newWb.SaveAs Filename:="book1.xlsx", FileFormat:=xlOpenXMLWorkbook
'②
wb.Close
Set wb = Workbooks.Open(Filename:="filename.csv")
Set ws = wb.Sheets(1)
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'フィルターを設定
ws.Range("A1:D" & lastRow).AutoFilter Field:=3, Criteria1:="00.000Z"
Set rng = ws.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible)
'結果を新しいExcelブックにコピー
Set ws = newWb.Sheets(2)
rng.Copy ws.Range("A1")
'ブックを保存
newWb.Save
'③
Set wb = Workbooks.Open(Filename:="ポイント情報照会.csv")
Set ws = wb.Sheets(1)
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'データを取得
Set rng = ws.Range("D2:D" & lastRow)
'結果を新しいExcelブックにコピー
Set ws = newWb.Sheets(3)
rng.Copy ws.Range("A1")
'ブックを保存
newWb.Save
'④
'条件に合わせて上記①と同じようにコードを記述する
'⑤
Set wb = Workbooks.Open(Filename:="ポイント情報照会.csv")
Set ws = wb.Sheets(1)
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'データを取得
Set rng = ws.Range("C2:C" & lastRow)
'結果を新しいExcelブックにコピー
Set ws = newWb.Sheets(5)
rng.Copy ws.Range("A1")
'ブックを保存
newWb.Save
'ブックを閉じる
new