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

Question

我目前有一個數據工作表，目的是挑選相關數據並進行匯總。 我通過根據代碼ID創建工作表來解決此問題（在這種情況下，我使用名稱），以代碼ID命名工作表，然后將所有特定的代碼ID復制並發送到他們的工作表中。 然后，插入新列，並插入公式以獲取相關數據。 創建一個“摘要表”，並在一行中僅包含代碼ID，並在其旁邊提供相關信息。 我很難將信息拉回到底部Module6中的摘要頁面。 我希望.Range("B1").Value = WorksheetFunction.Sum(Worksheets("David").Range("B:B"))這種情況下的工作表“ David”，。 .Range("B1").Value = WorksheetFunction.Sum(Worksheets("David").Range("B:B")) ， .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