使用单元格中的信息search工作簿
我目前有一个工作表的数据，我的目标是挑选出相关的数据并对其进行总结。 我已经通过创build工作表取决于代码ID（在这种情况下，我使用的名称），在代码ID后命名工作表，并复制并发送所有特定的代码ID到他们的工作表。 然后，插入一个新的列，并插入一个公式来获取相关数据。 创build一个“汇总表”，只有一列中的代码ID和旁边的相关信息。 我很难将信息拉回模块6底部的摘要页面。 我希望，而不是说在这种情况下，工作表“大卫”， .Range("B1").Value = WorksheetFunction.Sum(Worksheets("David").Range("B:B"))我可以从它旁边的单元格中读取工作表名称，以便数据始终匹配。 提前致谢。
Private Sub Button2_Click() Dim LR As Long Dim LG As Long Dim ws As Worksheet Dim vcol, i As Integer Dim icol As Long Dim myarr As Variant Dim title As String Dim titlerow As Integer Call First 'Module1 - Deletes irrelevant Rows and Columns from the "Data" Worksheet. Call Second 'Module2 - Moves rows to new worksheet depending on their IW code and renames the worksheet as the code. Call Third 'Module3 - Inserts a new column in every worksheet with the exception of Command and Data. Call Fourth 'Module4 - Inserts a formula, to calculate SOMTHING, in the every row of the new column created by the third call. Call Fifth 'Module5 - Creates new worksheet, "Summary", to display a summary of the data. Call Sixth 'Module6 - Sums the new column and displays the results in the summary sheet. End Sub Sub First() Application.DisplayAlerts = False With Worksheets("Data") .Rows("1:2").Delete 'Deletes first two rows .Columns("A:A").Delete 'Deletes column A .Rows("1:1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete 'Deletes entire column where there is a blank cell in the first row .Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Deletes entire row where there is a blank cell in the column B End With Application.DisplayAlerts = True End Sub Sub Second() vcol = 1 Set ws = Sheets("Data") LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row title = "A1:C1" titlerow = ws.Range(title).Cells(1).Row icol = ws.Columns.Count ws.Cells(1, icol) = "Unique" For i = 2 To LR On Error Resume Next If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) End If Next myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) ws.Columns(icol).Clear For i = 2 To UBound(myarr) ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" Else Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count) End If ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") Sheets(myarr(i) & "").Columns.AutoFit Next ws.AutoFilterMode = False ws.Activate End Sub Sub Third() 'Inserts a new column in every worksheet with the exception of Command and Data. For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Command" And ws.Name <> "Data" Then ws.Range("B:B").EntireColumn.Insert End If Next ws End Sub Sub Fourth() 'Inserts a formula, to calculate the product of two cells, located in the new column For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Command" And ws.Name <> "Data" Then LG = Range("C" & Rows.Count).End(xlUp).Row ws.Range("B2:B" & LG).Formula = "=C2*D2" End If Next ws End Sub Sub Fifth() 'Creates new worksheet, "Summary", to display a summary of the data. With ThisWorkbook Set ws = .Sheets.Add(After:=Sheets(2), Count:=1) ws.Name = "Summary" End With 'Lists the names of each worksheet x = 1 Sheets("Summary").Range("A:A").Clear For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Command" And ws.Name <> "Data" And ws.Name <> "Summary" Then Sheets("Summary").Cells(x, 1) = ws.Name x = x + 1 End If Next ws End Sub Sub Sixth() 'Sums the new column and displays the results in the summary sheet With Sheets("Summary") .Range("B1").Value = WorksheetFunction.Sum(Worksheets("David").Range("B:B")) .Range("B2").Value = WorksheetFunction.Sum(Worksheets("Michael").Range("B:B")) .Range("B3").Value = WorksheetFunction.Sum(Worksheets("Paul").Range("B:B")) End With End Sub
如果您只需在所有工作表中总结B：B列，则可以使用对象循环：
Sub Sixth() Dim ws As Worksheet Dim cnt As Long 'Sums the new column and displays the results in the summary sheet cnt = 1 For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Command" And ws.Name <> "Data" And ws.Name <> "Summary" Then With Sheets("Summary") .Range("B" & cnt).Value = WorksheetFunction.Sum(ws.Range("B:B")) End With cnt = cnt + 1 End If Next ws End Sub
不过，我认为你可以在Fifth（）子程序中做到这一点。 就像是：
For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Command" And ws.Name <> "Data" And ws.Name <> "Summary" Then Sheets("Summary").Cells(x, 1) = ws.Name Sheets("Summary").Cells(x, 2) = WorksheetFunction.Sum(ws.Range("B:B")) x = x + 1 End If Next ws