VBA遍历范围然后运行代码更新工作表参考

Question

对不起，我是一个寻求帮助的新手。我有一个完整的思维障碍，所以请寻求帮助。

我有一个包含几个宏的文档；第一次从数据表（数据表）中提取数据，并在满足标准时复制到特定的工作表（报告表）。第二个宏会将其保存为 PDF，创建电子邮件并将其发送给此人。

我有 100 多张工作表，需要将这些宏复制 100 次。

我想将这些组合成 1 个宏，但是，我想遍历一个范围（“B6:B123”），如果在该范围内单元格 0，那么宏需要运行，但报告表参考我想使用会触发它们运行的​​相邻单元格值 (Dx) 动态更新。

宏 1

Sub Search_extract_135()

Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim ocname As String
Dim finalrow As Integer
Dim i As Integer

Set datasheet = Sheet121 ' stays constant
Set reportsheet = Sheet135 'need to update based on range that <>0 then taking cell reference as

ocname = reportsheet.Range("A1").Value 'stays constant

reportsheet.Range("A1:U499").EntireRow.Hidden = False
reportsheet.Range("A5:U499").ClearContents

datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To finalrow
    If Cells(i, 1) = ocname Then
    Range(Cells(i, 1), Cells(i, 21)).Copy
    reportsheet.Select
    Range("A500").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
    datasheet.Select
    End If
    
Next i

reportsheet.Select
Range("A4").Select
Call HideRows

结束子

宏 2

Sub Send_Email_135()
Dim wPath As String, wFile As String, wMonth As String, strPath As String, wSheet As Worksheet
        
    Set wSheet = Sheet135
    wMonth = Sheets("Journal").Range("K2")
    wPath = ThisWorkbook.Path ThisWorkbook.Path
    wFile = wSheet.Range("A1") & ".pdf"
    wSheet.Range("A1:U500").ExportAsFixedFormat Type:=xlTypePDF, Filename:=wPath & "-" & wFile, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    strPath = wPath & "-" & wFile

    Set dam = CreateObject("Outlook.Application").CreateItem(0)
    '
    dam.To = wSheet.Range("A2")
    dam.cc = wSheet.Range("A3")
    dam.Subject = "Statement " & wMonth
    dam.Body = "Hi" & vbNewLine & vbNewLine & "Please find attached your statement." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "xxxxx"  
    dam.Attachments.Add strPath
    dam.Send
    MsgBox "Email sent"

End Sub

我希望这是有道理的。

下面会尝试总结一下；

excel文档的格式在A列中有名称，B列中有数值，D列中有SheetCode。当单元格在Range（“B6：B123”） 0时，然后运行上面的2个宏，但需要报表从宏 1 和宏 2 中的 wSheet 使用 D 列中的相同值来引用不等于 0 的人的特定工作表代码。

如果这不起作用，我将创建多个宏。

提前谢谢你。

Answer 1

解决方案是使用字典将代号转换为工作表编号并将参数传递给子例程，以便将相同的代码应用于许多不同的工作表。

Option Explicit

Sub Reporter()

    ' Journal sheet layout
    Const ROW_START = 6
    Const COL_NZ = "B" ' column to check <> 0
    Const COL_CODE = "D" ' sheet codenames

    ' Fixed sheet code names
    Const WS_DATA = "Sheet121"
    Const WS_JOURNAL = "Sheet5"

    Dim wb As Workbook, ws As Worksheet
    Dim wsReport As Worksheet, wsJournal As Worksheet, wsData As Worksheet
    Dim iLastRow As Long, i As Long, n As Long
    Dim sCodeName As String, sMonth As String

    ' build a dictionary of codename->sheetno
    Dim dict As Object, key As String
    Set dict = CreateObject("Scripting.Dictionary")
    Set wb = ThisWorkbook
    For Each ws In wb.Sheets
        dict.Add ws.CodeName, ws.Index
    Next
  
    ' assign Fixed sheets
    Set wsData = wb.Sheets(dict(WS_DATA)) ' or Sheet121
    Set wsJournal = wb.Sheets(dict(WS_JOURNAL)) ' or Sheet5
    sMonth = wsJournal.Range("K2")

    ' scan list of persons
    With wsJournal
        iLastRow = .Cells(Rows.Count, COL_CODE).End(xlUp).Row
        For i = ROW_START To iLastRow
            If .Cells(i, COL_NZ) <> 0 Then ' col B

                sCodeName = .Cells(i, COL_CODE) ' col D
                ' set sheet, create report and email it
                Set wsReport = wb.Sheets(dict(sCodeName))
                Call Create_Report(wsReport, wsData)
                Call Email_Report(wsReport, sMonth)
                n = n + 1
            End If
        Next
    End With
    MsgBox n & " emails sent", vbInformation

End Sub

Sub Create_Report(wsReport As Worksheet, wsData)

    Dim ocname As String, iLastRow As Long, i As Long
    Dim rngReport As Range

    With wsReport
        ocname = .Range("A1").Value 'stays constant
        .Range("A1:U500").EntireRow.Hidden = False
        .Range("A5:U500").ClearContents
        Set rngReport = .Range("A5")
    End With

    ' scan down data sheet and copy to report sheet
    Application.ScreenUpdating = False
    With wsData
        iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To iLastRow
            If wsData.Cells(i, 1) = ocname Then
                .Cells(i, 1).Resize(1, 21).Copy rngReport
                Set rngReport = rngReport.Offset(1)
            End If
        Next i
    End With
    'Call HideRows
    Application.ScreenUpdating = True

End Sub

Sub Email_Report(wsReport As Worksheet, sMonth As String)

    Dim sPDFname As String, oMail As Outlook.MailItem
    sPDFname = ThisWorkbook.Path & "\" & wsReport.Range("A1") & ".pdf"
 
    Dim oOut As Object ' Outlook.Application
    Set oOut = CreateObject("Outlook.Application")

    Set oMail = oOut.CreateItem(0)
    With oMail
        wsReport.Range("A1:U500").ExportAsFixedFormat _
        Type:=xlTypePDF, Filename:=sPDFname, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False

        .To = wsReport.Range("A2").Value2
        .cc = wsReport.Range("A3").Value2
        .Subject = "Statement " & sMonth
        .Body = "Hi" & vbNewLine & vbNewLine & _
                "Please find attached your statement." & vbCr & vbCr & _
                "Regards," & vbCr & "xxxxx"
        .Attachments.Add sPDFname
        .Display ' or .Send
    End With
    
    MsgBox "Email sent to " & wsReport.Range("A2").Value2, , wsReport.Name
    oOut.Quit

End Sub