我正在尝试遍历我的工作表，并排除某些工作表（如下所示）。每个月都要运行此代码，需要将该月的所有数据复制到累积文件中。由WhatFor Value定义。
如果是代码运行的第一个月，则需要将所有历史数据与该月一起复制。
我在下面的代码创建累积文档是不存在的，并复制该月的数据。如果我再次运行代码，则会在wbNew.sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlValues
如果是第一个月，我似乎无法循环遍历所有行，工作表并复制所有数据。
Private Sub CommandButton2_Click()
Dim MyPath As String: MyPath = ThisWorkbook.Path
Dim myData As Workbook, wb As Workbook, wbNew As Workbook
Dim WhatFor As String, sheet As Worksheet, FirstAddress As String, cell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.DisplayAlerts = False
End With
WhatFor = ThisWorkbook.sheets("PAYMENT FORM").Range("L9")
If Dir(MyPath & "\Cumulative.xls") = "" Then
Set wb = ThisWorkbook
Workbooks.Add
Set wbNew = ActiveWorkbook
wbNew.sheets("Sheet1").Activate
wbNew.sheets("Sheet1").Range("A1:O1").Interior.ColorIndex = 37
With wbNew.sheets("Sheet1").Range("A1:O1").Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With wbNew.sheets("Sheet1").Columns("I:L")
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End With
With wbNew.sheets("Sheet1")
wbNew.sheets("Sheet1").Range("A1") = "Payment No#"
wbNew.sheets("Sheet1").Range("B1") = "WO No#"
wbNew.sheets("Sheet1").Range("C1") = "Address"
wbNew.sheets("Sheet1").Range("D1") = "Discription"
wbNew.sheets("Sheet1").Range("E1") = "Discription2"
wbNew.sheets("Sheet1").Range("F1") = "Discription3"
wbNew.sheets("Sheet1").Range("G1") = "Discription5"
wbNew.sheets("Sheet1").Range("H1") = "Discription5"
wbNew.sheets("Sheet1").Range("I1") = "Labout Costs"
wbNew.sheets("Sheet1").Range("J1") = "Total Claimed"
wbNew.sheets("Sheet1").Range("K1") = "Costs Omitted"
wbNew.sheets("Sheet1").Range("L1") = "Costs Certified"
wbNew.sheets("Sheet1").Range("M1") = "Type of Work"
wbNew.sheets("Sheet1").Range("N1") = "S/C's App Notes / Notes"
wbNew.sheets("Sheet1").Range("O1") = "Paid Under"
wbNew.sheets("Sheet1").Range("A1:O1").Columns.AutoFit
End With
wbNew.sheets(Array("Sheet2", "Sheet3")).Delete
For Each sheet In ThisWorkbook.sheets
`exclude these ->` If sheet.Name <> "PAYMENT FORM" And sheet.Name <> "Global" And sheet.Name <> "MergedData" And sheet.Name <> "Details" And sheet.Name <> "Template" Then
With sheet.Columns(1)
Set cell = .Find(what:= **<0**, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
sheet.Columns("O:R").ClearContents
cell.EntireRow.Copy
wbNew.sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlValues
wbNew.sheets("Sheet1").Range("O" & Rows.Count).End(xlUp).Offset(1, 0).value = sheet.Name
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
End If
End With
End If
Next sheet
wbNew.SaveAs Filename:=MyPath & "\Cumulative.xls", FileFormat:=56
wbNew.Close
Exit Sub
Else
Set myData = Workbooks.Open(MyPath & "\Cululative.xls")
DoEvents
For Each sheet In ThisWorkbook.sheets
If sheet.Name <> "PAYMENT FORM" And sheet.Name <> "Global" And sheet.Name <> "MergedData" And sheet.Name <> "Details" And sheet.Name <> "Template" Then
With sheet.Columns(1)
Set cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
sheet.Columns("O:R").ClearContents
cell.EntireRow.Copy
wbNew.sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlValues
wbNew.sheets("Sheet1").Range("O" & Rows.Count).End(xlUp).Offset(1, 0).value = sheet.Name
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
End If
End With
End If
Next sheet
myData.Save
myData.Close
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.DisplayAlerts = True
End With
End Sub
答案 0 :(得分：0)
非常确定这不是你之后的全部答案。我已经整理了你的代码，改变了一些可以更容易完成的事情，并且可能对你的实际问题有帮助吗？
Private Sub CommandButton2_Click()
Dim MyPath As String
Dim myData As Workbook, wb As Workbook, wbNew As Workbook
Dim WhatFor As String, sheet As Worksheet, FirstAddress As String, cell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.DisplayAlerts = False
End With
Set wb = ThisWorkbook 'You've defined ThisWorkbook here - so use it throughtout the procedure.
MyPath = wb.Path
WhatFor = wb.Sheets("PAYMENT FORM").Range("L9").Value 'Be explicit - you want the value.
If Dir(MyPath & "\Cumulative.xls") = "" Then
Set wbNew = Workbooks.Add(xlWBATWorksheet) 'Create a book with 1 sheet.
With wbNew.Sheets(1)
With .Range("A1:O1")
.Interior.ColorIndex = 37
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With .Columns("I:L")
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End With
.Range("A1:O1") = Array("Payment No#", "WO No#", "Address", "Discription", "Discription2", _
"Discription3", "Discription5", "Discription5", "Labout Costs", "Total Claimed", _
"Costs Omitted", "Costs Certified", "Type of Work", "S/C's App Notes / Notes", _
"Paid Under")
.Range("A1:O1").Columns.AutoFit
End With
For Each sheet In wb.Worksheets
Select Case sheet.Name
Case "PAYMENT FORM", "Global", "MergedData", "Details", "Template"
'These sheets are excluded, so do nothing?
'If you want to do something - put your code here.
Case Else
With sheet.Columns(1)
Set cell = .Find(What:=1, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
sheet.Columns("O:R").ClearContents
FirstAddress = cell.Address
Do
cell.EntireRow.Copy
wbNew.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlValues
wbNew.Sheets("Sheet1").Range("O" & Rows.Count).End(xlUp).Offset(1, 0).Value = sheet.Name
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
End If
End With
wbNew.SaveAs Filename:=MyPath & "\Cumulative.xls", FileFormat:=56
wbNew.Close
End Select
Next sheet
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.DisplayAlerts = True
End With
End Sub