将单元格匹配和复制到摘要工作表/ VBA中
我需要find一种方法将多个工作表中的数据复制到汇总表中。 来自所有这些数据的表单（块的数量和大小各不相同）
账号在上面，一边是不同的警报，另一边是多个块。
我的目标是复制并粘贴到此表中：
其中左侧有帐号，顶部有不同的警报。 每张表中的每个帐户都在该表中，每个警报（唯一）也是如此。 现在我计划从工作表中获取数据是遍历每张工作表，并尝试将每个单元格与表中的警报和帐号匹配，然后插入它。
Private Sub CommandButton24_Click() Dim xSheet As Worksheet, DestSh As Worksheet Dim Last As Long, crow As Long, ccol As Long Dim copyRng As Range, destRng As Range, colSrc As Range, rowSrc As Range Dim cRange As Range, copyTemp As Range, copyEnd As Range, copyStart As Range Dim exchDest As Range, rowRange As Range Dim numCol As Long, numRow As Long Dim c As Range, q As Range Dim uniqueVal() As Variant, x As Long With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With Set destRng = DestSh.Range("E2") 'Loop through all worksheets and copy numbers to the 'summary worksheet. For Each xSheet In ActiveWorkbook.Worksheets If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _ 'Set relevant range Set copyStart = xSheet.Range("A1") crow = xSheet.Cells(Rows.Count, 1).End(xlUp).Row ccol = xSheet.Cells(1, Columns.Count).End(xlToRight).Column Set copyEnd = xSheet.Cells(crow, ccol) Set copyRng = xSheet.Range(copyStart, copyEnd) 'loop through range For Each c In copyRng.SpecialCells(xlCellTypeVisible) If IsNumeric(c) And c.Value <> "0" Then _ 'I am ignoring 0s since they will be added back later Set rowRange = xSheet.Range(c, c.EntireColumn.Cells(1)) 'set range from cell up to the top cell of the comment For Each q In copyRng.SpecialCells(xlCellTypeVisible) 'Loop through that range and find the Account number just above it and set it as rowSrc If InStr(1, q.Value, "C-") Then _ Set rowSrc = q Next q Set colSrc = c.EntireRow.Offset(0).Cells(1) 'find alert connected with the number numCol = DestSh.Cells.Find(colSrc.Value, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column 'look for the column in which the same alert is listed numRow = DestSh.Cells.Find(rowSrc.Value, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row 'look for row in which the same account is listed 'Set destination Set destRng = DestSh.Cells(numRow, numCol) 'Copy to destination Range c.Copy destRng End If Next c End If Next xSheet ExitTheSub: Application.Goto DestSh.Cells(1) With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub 到目前为止，我还没有设法定义单元格上方的范围以查找帐号。 它总是好像只是B1 ，对我来说根本毫无意义。 实际的代码有点长，因为它也会生成包含帐号和警报的摘要选项卡。 我知道这是一个很长的问题，但是我已经在3天的时间里做了很多的工作，我想我会问一个长问题，而不是五个短的问题，而忽略了大局。 如果你能提出一个更好的解决这个问题的方法，我也很乐意听到。
我很高兴你解决了你的问题。 同时，我一直在根据我昨天指出的工作stream程准备另一种方法。 这是学术上的，但对你来说，对我来说还是更有价值的，太多的工作把它扔掉了:-)。 也许你可以使用它的一些部分。
Private Sub CommandButton24_Click() ' 24 Aug 2017 ' Variable naming (throughout the project): ' Use Ws for worksheet, Rng for Range ' Use R for row, C for column ' Use S (or s) for source, T (or t) for target Dim Wb As Workbook Dim WsS As Worksheet, WsT As Worksheet ' Source & Target Set Wb = ActiveWorkbook ' this is different from ThisWorkbook !! On Error Resume Next Set WsT = Wb.Worksheets("Summary") If Err Then Set WsT = Wb.Worksheets.Add(Before:=Worksheets(1)) WsT.Name = "Summary" Else WsT.Cells.ClearContents ' ensure the sheet is blank End If On Error GoTo 0 SetAppProps False ' Loop through all worksheets: ' don't use For .. Each if there are frequent deletions or additions ' of worksheets in this workbook. Use Worksheet(Index) instead. For Each WsS In Wb.Worksheets With WsS If StrComp(.Cells(1, "B").Text, "No Summary Available", vbTextCompare) And _ InStr(1, .Name, "ACCOUNT", vbTextCompare) > 0 Then Application.StatusBar = "Processing " & .Name If Not CopyToSummary(WsS, WsT) Then MsgBox "An error occurred while processing" & vbCr & _ "sheet """ & .Name & """." & vbCr & _ "I am abandoning the task.", _ vbCritical, "Programm failure" Exit For End If End If End With Next WsS SetAppProps True End Sub Private Function CopyToSummary(WsS As Worksheet, _ WsT As Worksheet) As Boolean ' 24 Aug 2017 ' return Not True if an error occurred Dim Rs As Long, Cs As Long ' source coordinates Dim Rt As Long, Ct As Long ' target coordinates Dim Rl As Long, Cl As Long ' last row or column Dim AccNum As String ' account number ' it is critical that AccNum is defined correctly ' either as string or as some type of number. What is it? Dim Commt As String Dim CopyRng As Range With WsS ' find the last used column in row 2: is that correct ???? Cl = .Cells(2, .Columns.Count).End(xlToLeft).Column For Cs = 1 To Cl ' Examine each column ' starting with Columns(1) ??? Rl = .Cells(.Rows.Count, Cs).End(xlUp).Row ' CopyRng = Account number and comments below it: (starting from Rows(1)) Set CopyRng = .Range(.Cells(1, Cs), .Cells(Rl, Cs)) AccNum = CopyRng.Cells(1).Value ' AccNum is found in Rows(1) ??? Rt = SummaryRow(AccNum, WsT) ' AccNum will be copied to WsT even if there are no comments ' Now take each cell below the account number in WsS starting in row 2 For Rs = 2 To CopyRng.Cells.Count ' no blank row below AccNum in WsS Commt = CopyRng.Cells(Rs) Ct = SummaryColumn(Commt, WsT) ' In WsT.Cells(Rt, Ct) write what ????? Next Rs Next Cs End With CopyToSummary = True End Function Private Sub TestSummaryColumn() Dim Commt As String Dim WsT As Worksheet Commt = "not Something" Set WsT = Worksheets("Summary") Debug.Print SummaryColumn(Commt, WsT) End Sub Private Function SummaryColumn(Commt As String, _ WsT As Worksheet) As Long ' 24 Aug 2017 Dim Fun As Long ' function return value Dim Rng As Range ' search range for Commt Dim Cl As Long ' last column in WsT With WsT ' hard-programmed: .Rows(1) has comments Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column ' hard-programmed: Cell(A1) must not have a comment occurring in WsS Set Rng = .Range(.Cells(1, 1), .Cells(1, Cl)) End With On Error Resume Next Fun = Application.Match(Commt, Rng, 0) ' Search for the comment in WsT.Rows(1) If Err Then ' IF the value isn't found ' add a new column on the right: Fun = Cl + 1 ' Format WsT.Columns(Fun) Err.Clear End If ' ELSE the cound column is "Fun" (already so) SummaryColumn = Fun End Function Private Sub TestSummaryRow() Dim AccNum As String Dim WsT As Worksheet AccNum = "016" Set WsT = Worksheets("Summary") Debug.Print SummaryRow(AccNum, WsT) End Sub Private Function SummaryRow(AccNum As String, _ WsT As Worksheet) As Long ' 24 Aug 2017 Dim Fun As Long ' function return value Dim Rng As Range ' search range for AccNum Dim Rl As Long ' last row With WsT ' hard-programmed: .Columns(1) has account numbers Rl = .Cells(.Rows.Count, 1).End(xlUp).Row ' hard-programmed: First account number is in Rows(1) - no column captions: Set Rng = .Range(.Cells(1, 1), .Cells(Rl, 1)) End With On Error Resume Next Fun = Application.Match(AccNum, Rng, 0) ' Check if the account number already exists in WsT.Columns(1) If Err Then ' IF the account number is not found Fun = Rl + 1 ' add the account number in a new row "Fun" Err.Clear End If ' ELSE the found row is "Fun" (already so) SummaryRow = Fun End Function Private Sub SetAppProps(ByVal AppMode As Boolean) ' 24 Aug 2017 With Application .ScreenUpdating = AppMode .EnableEvents = AppMode .Calculation = Array(xlCalculationManual, xlCalculationAutomatic)(Int(AppMode) + 1) .StatusBar = "" End With End Sub
代码没有完成。 以上是打算作为布局。 其中一个不太明显的丢失端是CopyToSummary函数的返回值。 如代码所示，它总是返回True。 如果发生错误，应该编程为跳过最后一行，或者在这种情况下返回False。
我知道这不是你的问题的答案，但你的问题需要刷新出来，才能处理，我需要代码格式来显示我的意思。 这里是定义你的CopyRange的代码。 它消除了在你的语法中很难find的歧义。
With xSheet R = .Cells(.Rows.Count, 1).End(xlUp).Row ' observe the period before Rows.Count C = .Cells(1, .Columns.Count).End(xlToRight).Column ' observe the period before Columns.Count Set CopyRng = .Range(.Cells(1, 1), .Cells(R, C)) End With For Each CopyCell In CopyRng If IsNumeric(CopyCell.Value) And CopyCell.Value <> "0" Then 'I am ignoring 0s since they will be added back later With xSheet Set RowRng = .Range(.Cells(1, CopyCell.Column), CopyCell) 'set range from cell up to the top cell of the comment End With For Each q In CopyRng ' here you are committing logical error: ' you are already looping through all cells in CopyRng
恐怕我的任务在这里成功的希望渺茫。 有一件事对我来说太迟了。 对于另一个不可能find没有数据testing的所有错误。 我希望上面的内容能给你一点帮助，让你自己继续下去。 使用更多的描述性variables名称也将有助于使您的代码更具可读性。
除非您早晨已经解决了您的问题，否则请确认以下是您的计划或纠正错误理解的顺序。 同时回答计划中包含的问题。
For Each xSheet In ActiveWorkbook.Worksheets If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then ' Examine each column ' starting with columns(1) ?? ' Take the account number from rows(1) ' Check if the account number already exists in DestSh.Columns(1) ' which is the first row with data in DestSh ?? ' IF the account number is not found ' add the account number in a new row "R" ' ELSE the found row is "R" ' Now take each cell below the account number in xSheet ' starting in row 2 ???? ' Search for the value of that cell in DestSh.Rows(1) ' IF the value isn't found ' add a new column on the right and all it "C" ' ELSE the cound column is "C" ' In DestSh.Cells(R, C) write what ????? ' continue until the end of the xSheet.Column with the account number at the top ' then take the next column