Option Explicit
Sub CopyData()
Dim tgtRow As ListRow
' 申請書ファイルを開く
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "申請書.xlsx"
' 「読み取り」シートのセルA1にある数字を読み取る
' Dim sheetNum As Integer
' sheetNum = Workbooks("申請書.xlsx").Sheets("読み取り").Range("A1").Value
' 読み取った数字に対応するシートを選ぶ
' Workbooks("申請書.xlsx").Sheets(sheetNum).Select
' テーブル名「Shinsei」の情報を読み取る
Dim tbl As ListObject
Set tbl = Workbooks("申請書.xlsx").Sheets(1).ListObjects("route")
' とりまとめファイルを開く
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "とりまとめ.xlsx"
' テーブル名「Torimatome」にShinseiの情報を転記する
Dim tgtTbl As ListObject
Set tgtTbl = Workbooks("とりまとめ.xlsx").Sheets(1).ListObjects("route")
Dim i As Integer
For i = 1 To 4
' 判定カラムの値に応じて、行を追加または削除する
Dim judge As Integer
judge = tbl.ListRows(i).Range.Columns(1).Value
If judge = 1 Then ' 判定カラムが1ならば、行を追加する
Set tgtRow = tgtTbl.ListRows.Add
tbl.ListRows(1).Range.Copy tgtRow.Range
ElseIf judge = 2 Then ' 判定カラムが2ならば、対応する行を削除する
Dim j As Long
For j = 1 To tgtTbl.DataBodyRange.Count
If tgtTbl.DataBodyRange(j, 2).Value = tbl.DataBodyRange(i, 2).Value Then
Set tgtRow = tgtTbl.ListRows(j) ' 削除する行を指定する
tgtRow.Delete
Exit For
End If
Next j
ElseIf judge = "" Then ' 判定カラムがならば、対応する行を削除する
Exit For
Else ' 判定カラムが1または2以外の場合、エラーメッセージを表示する
MsgBox "判定カラムの値が不正です。", vbExclamation, "エラー"
End If
Next i
' 申請書ファイルととりまとめファイルを保存して閉じる
Workbooks("申請書.xlsx").Save
Workbooks("申請書.xlsx").Close
Workbooks("とりまとめ.xlsx").Save
Workbooks("とりまとめ.xlsx").Close
End Sub
Sub ReadFiles()
' フォルダのパスを指定する
Dim folderPath As String
folderPath = "C:\example\folder"
' 指定したフォルダ内のすべてのExcelファイルに対してループを実行する
Dim file As String
file = Dir(folderPath & "\*.xlsx")
Do While file <> ""
' Excelファイルを開く
Dim wb As Workbook
Set wb = Workbooks.Open(folderPath & "\" & file)
' 上書き保存するシートを指定する
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")
' シートに対して上書き保存を実行する
ws.Range("A1").Value = "New Value"
wb.Save
' Excelファイルを閉じる
wb.Close SaveChanges:=False
' 次のファイルに進む
file = Dir()
Loop
End Sub
コメントを残す