Sub 集計施策()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim lr As Long
Dim lr2 As Long
Dim rg As Range
Dim cop As Variant
Set ws = Worksheets("ATT集計")
'前回の集計結果を削除
ws.Range(Cells(2, 1), Cells(30000, 30)).ClearContents
'シートの繰り返し処理
For i = 1 To Day(Date) - 1
Set ws2 = Worksheets(i & "日")
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'シート内各行の繰り返し処理
For j = 2 To lr2
'行内各セルの繰り返し処理
For Each rg In ws2.Range(ws2.Cells(j, 13), ws2.Cells(j, 16))
If rg <> "" Then
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
cop = ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 17))
ws.Range(ws.Cells(lr, 1), ws.Cells(lr, 17)) = cop
Exit For
End If
Next rg
Next j
Next i
End Sub
Sub 集計他シートから()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim file As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim lr2 As Long
Dim rg As Range
Dim cop As Variant
Set wb = Workbooks("マクロ実験.xlsm")
Set ws = wb.Worksheets("ATT集計")
file = ws.Range("B1")
Workbooks.Open file
Set wb2 = Workbooks("マクロ実験2.xlsm")
'前回の集計結果を削除
ws.Range(ws.Cells(2, 1), ws.Cells(30000, 30)).ClearContents
'シートの繰り返し処理
For i = 1 To Day(Date) - 1
Set ws2 = wb2.Worksheets(i & "日")
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'シート内各行の繰り返し処理
For j = 2 To lr2
'行内各セルの繰り返し処理
For Each rg In ws2.Range(ws2.Cells(j, 13), ws2.Cells(j, 16))
If rg <> "" Then
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
cop = ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 17))
ws.Range(ws.Cells(lr, 1), ws.Cells(lr, 17)) = cop
Exit For
End If
Next rg
Next j
Next i
MsgBox "抽出が完了しました"
End Sub
Sub 集計M列のみ()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim file As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim lr2 As Long
Dim rg As Range
Dim cop As Variant
Set wb = Workbooks("マクロ実験.xlsm")
Set ws = wb.Worksheets("ATT集計")
file = ws.Range("B1")
Workbooks.Open file
Set wb2 = Workbooks("マクロ実験2.xlsm")
'前回の集計結果を削除
ws.Range(ws.Cells(2, 1), ws.Cells(30000, 30)).ClearContents
'シートの繰り返し処理
For i = 1 To Day(Date) - 1
Set ws2 = wb2.Worksheets(i & "日")
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'シート内各行の繰り返し処理
For j = 2 To lr2
'行内各セルの繰り返し処理
For Each rg In ws2.Range(ws2.Cells(j, 13), ws2.Cells(j, 13))
If rg <> "" Then
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
cop = ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 12))
ws.Range(ws.Cells(lr, 1), ws.Cells(lr, 12)) = cop
ws.Cells(lr, 13) = ws2.Cells(j, 13)
Exit For
End If
Next rg
Next j
Next i
MsgBox "抽出が完了しました"
End Sub
Sub 集計N列のみ()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim file As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim lr2 As Long
Dim rg As Range
Dim cop As Variant
Set wb = Workbooks("マクロ実験.xlsm")
Set ws = wb.Worksheets("ATT集計")
file = ws.Range("B1")
Workbooks.Open file
Set wb2 = Workbooks("マクロ実験2.xlsm")
'前回の集計結果を削除
ws.Range(ws.Cells(2, 1), ws.Cells(30000, 30)).ClearContents
'シートの繰り返し処理
For i = 1 To Day(Date) - 1
Set ws2 = wb2.Worksheets(i & "日")
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'シート内各行の繰り返し処理
For j = 2 To lr2
'行内各セルの繰り返し処理
For Each rg In ws2.Range(ws2.Cells(j, 14), ws2.Cells(j, 14))
If rg <> "" Then
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
cop = ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 12))
ws.Range(ws.Cells(lr, 1), ws.Cells(lr, 12)) = cop
ws.Cells(lr, 14) = ws2.Cells(j, 14)
Exit For
End If
Next rg
Next j
Next i
MsgBox "抽出が完了しました"
End Sub