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

使用单元格

1 个答案: