使用单元格中的信息搜索工作簿

Question

我目前有一个数据工作表，我的目标是挑选出相关数据并进行总结。我通过根据代码 ID 创建工作表(在此方案中我使用名称(来实现这一点，以代码 ID 命名工作表，然后将所有特定的代码 ID 复制并发送到他们的工作表。然后，插入一个新列，并插入一个公式以获取相关数据。创建一个"摘要表"，并且仅在一列中包含代码 ID，并在旁边包含相关信息。我很难将信息拉回模块 6 底部的摘要页面。我希望在这种情况下，与其说特定的工作表"David"，.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

Answer 1

如果您只需要对所有工作表中的 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