我正在使用 Microsoft Excel 来跟踪任务。我为每项工作使用不同的“工作表”。该结构与列和数据有关。我一直在尝试创建一个 VBA 脚本来完成以下任务：
- 在工作表 1 - X 中连续搜索“未结”或“逾期”值
- 将具有这些值的所有行复制到从第 3 行开始的单个工作表（例如分类帐）中（这样我就可以添加模板的标题）
- 添加带有工作表名称的 A 列，以便我知道它来自什么工作。
- 把这个跑到我心里强迫性行为快乐更新新项目
我一直在使用以下帖子来帮助指导我：
搜索特定单词并将行复制到另一个工作表<- 这很有帮助但不太正确......
根据在标签网格上的搜索将行复制到另一个工作表<-- 也很有帮助，但仅限于活动表，并且我的修改无法正确循环...
过去的两个晚上很有趣，但我觉得我可能会让这变得比必要的更难。
我能够创建一个 VBA 脚本（从此处的另一篇文章编辑）来扫描所有工作表，但它旨在复制一组列中的所有数据。我测试了它并且它有效。然后，我将用于识别 C 列（仅适用于活动表）中的“打开”或“过期”的代码库合并到代码中。我标记了我的编辑以在这里分享。在这一点上，它不起作用，我走路时头晕目眩。任何关于我在哪里对代码进行 fubar-ed 的提示都将不胜感激。我工作的代码库是：
Sub SweepSheetsCopyAll()
Application.ScreenUpdating = False
'following variables for worksheet loop
Dim W As Worksheet, r As Single, i As Single
'added code below for finding the fixed values on the sheet
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim h As Long 'h replaced i variable from other code
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
'insert below row match search copy function
For Each cell In Range("B1:L1").Offset(r - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
' original code Rows(r).Copy Destination:=Sheets(2).Rows(j)
Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
j = j + 1
End If
toCopy = False
'Next
'end above row match search function
'below original code that copied everything from whole worksheet
' If W.Cells(r, 1) > 0 Then
' Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
' ThisWorkbook.Worksheets("Summary").Cells(i, 1)
' i = i + 1
' End If
Next r
End If
Next W
End Sub
扫描所有工作表的工作代码库是：
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
并且从 Activesheet 中复制匹配的数据如下：
Sub customcopy()
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
For Each cell In Range("B1:L1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
End Sub