如何根据单元格值将数据复制到其他工作表

这里有三个替代方案来说明如何解决它

首选的是“可打印”表格中的查找公式，但正如您所说，您正在学习，我编写了其他选项。

阅读每一行中的注释，调整参数，然后按代码F8查看每一行中发生的情况。测试所有三个Public程序。

对于选项 1，设置一个这样的工作表Printable：

查找公式：=INDEX(Sheet1!$A2:$C2;;$B$1)指定 $A2:$C2 其中 A 到 C 是包含数据的源工作表中的列（可能是 500 列），2 是与名称对应的行（如果向下复制，它是指另一个行）

将以下代码复制到module

Option Explicit

' OPTION 1
' Have a printable sheet with lookup formulas and print that sheet
Public Sub LookupAndPrint()

    Dim sourceSheet As Worksheet
    Dim printableSheet As Worksheet

    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long
    Dim counter As Long

    Dim sourcePath As String
    Dim fileName As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set printableSheet = ThisWorkbook.Worksheets("Printable")

    firstColumn = 2 ' = B
    nameRow = 2 ' Relative to sheet

    ' Get the last column with data
    lastColumn = sourceSheet.Cells(nameRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Get current file path
    sourcePath = ThisWorkbook.path

    For counter = firstColumn To lastColumn

        ' Set the lookup column's number
        printableSheet.Range("B1").Value = counter

        ' Set the file name
        fileName = printableSheet.Range("B3").Value
        fileName = Replace(fileName, ".", "_")
        fileName = Replace(fileName, " ", "")

        ' Export the sheet
        exportToPDF printableSheet, sourcePath, fileName

    Next counter

End Sub

Private Sub exportToPDF(ByVal sourceSheet As Worksheet, ByVal path As String, ByVal fileName As String)

    Dim cleanFileName As String
    Dim fullPath As String

    cleanFileName = Replace(fileName, ".", "_")
    cleanFileName = Replace(cleanFileName, " ", "")

    fullPath = path & "\" & cleanFileName

    sourceSheet.ExportAsFixedFormat xlTypePDF, fullPath

End Sub


' OPTION 2
' You can hide other columns and export to PDF
Public Sub HideColumnsAndPrintToPDF()

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim evalRange As Range
    Dim sourceColumn As Range

    Dim firstRow As Long
    Dim lastRow As Long
    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long

    Dim sourcePath As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")

    firstRow = 2
    lastRow = 15
    firstColumn = 2 ' = B
    nameRow = 1 ' Relative to firstRow



    ' Get the last column with data
    lastColumn = sourceSheet.Cells(firstRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Set the evaluated range
    Set evalRange = sourceSheet.Range(sourceSheet.Cells(firstRow, firstColumn), sourceSheet.Cells(lastRow, lastColumn))

    ' Get current file path
    sourcePath = ThisWorkbook.path

    ' Loop through each column in range
    For Each sourceColumn In evalRange.Columns

        ' Hide other columns
        hideOtherColumns sourceColumn.Column, evalRange

        ' Export to pdf
        exportToPDF sourceSheet, sourcePath, sourceColumn.Cells(nameRow).Value

    Next sourceColumn

End Sub

Private Sub hideOtherColumns(ByVal currentColumn As Long, ByVal evalRange As Range)

    Dim evalColumn As Range

    For Each evalColumn In evalRange.Columns

        evalColumn.EntireColumn.Hidden = (evalColumn.Column <> currentColumn)

    Next evalColumn

End Sub



' OPTION 3
' If you plan to copy data to sheets
Public Sub CopyDataToSheets()

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim evalRange As Range
    Dim sourceColumn As Range

    Dim firstRow As Long
    Dim lastRow As Long
    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long

    Dim sourcePath As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")

    firstRow = 2
    lastRow = 15
    firstColumn = 2 ' = B
    nameRow = 1 ' Relative to firstRow



    ' Get the last column with data
    lastColumn = sourceSheet.Cells(firstRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Set the evaluated range
    Set evalRange = sourceSheet.Range(sourceSheet.Cells(firstRow, firstColumn), sourceSheet.Cells(lastRow, lastColumn))

    ' Get current file path
    sourcePath = ThisWorkbook.path

    ' Loop through each column in range
    For Each sourceColumn In evalRange.Columns

        ' Get the sheet based on the name
        Set targetSheet = getSheet(sourceColumn.Cells(nameRow).Value)

        ' Check that a sheet was found
        If Not targetSheet Is Nothing Then

            ' Copy data to sheet
            sourceColumn.Copy Destination:=targetSheet.Range("A1")

            ' Export to pdf
            exportToPDF targetSheet, sourcePath, sourceColumn.Cells(nameRow).Value

        End If

    Next sourceColumn

End Sub

Private Function getSheet(ByVal sheetName As String) As Worksheet

    Dim sheet As Worksheet

    For Each sheet In ThisWorkbook.Worksheets
        ' Use this if names are approximate, or: sheet.name = sheetName if names should be equal
        If InStr(LCase$(sheet.Name), LCase$(sheetName)) > 0 Then ' If sheet.name = sheetName then
            Set getSheet = sheet
        End If
    Next sheet

End Function

让我知道它是否有效