基于单元格值的Excel宏复制范围粘贴偏移量

Question

我有两张表格“数据”-其中有原始数据和“报表”-作为报表形式。

• 报告表的前5行具有信息。
• 数据表中有6列数据可用（编号名称Desig Place性别类别）
• 报告表仅包含前5列（SlNo Name Desig Place性别）
• 报告表范围C5是下拉框（“数据表的类别”列中的列表）。

因此，基于此C5值，请从数据表中获取详细信息，然后粘贴到报告表中。

我尝试了以下代码，但是当我只想在偏移量和循环中粘贴Name，Desig，Place，gender细节时，它将粘贴整行...

Sub ViewBtn()
Dim SCHL As String
Dim x As Long
x = 2
Do While Cells(x, 1) <> ""
Sheets("Report").Range(Cells(x, 1).Address, Cells(x, 5).Address).ClearContents
x = x + 1
Loop
Dim id As String
id = ActiveSheet.Range("C5").Value
x = 2
Sheets("Data").Select
Category = id
Do While Cells(x, 1) <> ""
If Cells(x, 4) = Category Then
Worksheets("Data").Rows(x).Copy
Worksheets("Report").Activate
erow = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Report").Rows(erow)
  End If
Worksheets("Data").Activate
 x = x + 1
   Loop
  Application.CutCopyMode = False
 Worksheets("Report").Activate

 End Sub

Answer 1

这是一些示例代码，可以满足我的要求。 这不一定是最短或最聪明的方法，但是所有步骤都是一步一步完成的，因此我希望它足够清晰，易于执行。

Option Explicit

Private Sub viewBtn_Click()

    '// Set references to worksheets
    Dim wsReport As Worksheet: Set wsReport = Sheets("Report")
    Dim wsData As Worksheet: Set wsData = Sheets("Data")

    '// Get the category to be reported
    Dim sCategory As String
    sCategory = wsReport.Range("C5")

    '// Reference first line of the report, in row 8
    Dim rFirstReportLine As Range
    Set rFirstReportLine = wsReport.Range("A8:E8")

    '// Reference the line of the report to be written
    Dim rReportLine As Range
    Set rReportLine = rFirstReportLine

    '// Clear the old report area
    Do While rReportLine.Cells(1, 1) <> ""
        rReportLine.Clear
        Set rReportLine = rReportLine.Offset(1, 0)
    Loop

    '// Reset to first line of the report
    Set rReportLine = rFirstReportLine

    '// Find the first cell, if any, that matches the category
    Dim rMatch As Range
    Set rMatch = wsData.Range("F:F").Find(sCategory, , , xlWhole)


    '// Get reference to top data row of data sheet, just the cols to be copied
    Dim rDataRow As Range: Set rDataRow = wsData.Range("A1:E1")

    '// check for at least one match
    If Not rMatch Is Nothing Then

        '// Save the address of the first match for checking end of loop with FindNext
        Dim sFirstMatchAddress As String:   sFirstMatchAddress = rMatch.Address

        Do
            '// 1) .. copy data row to the report line
            rDataRow.Offset(rMatch.Row - 1).Copy rReportLine

            '// 2) .. move the report line down
            Set rReportLine = rReportLine.Offset(1, 0)

            '// 3) .. find the next match on category
            Set rMatch = wsData.Range("F:F").FindNext(rMatch)

            '// 4) .. exit when we have looped around
        Loop Until rMatch.Address = sFirstMatchAddress
    End If

    '// Display the number of entries found at the end of the report
    With rReportLine
        Dim nEntryCount As Integer: nEntryCount = .Row - rFirstReportLine.Row
        .Cells(1, 1) = nEntryCount & IIf(nEntryCount = 1, " Entry", " Entries")
        .Font.Italic = True
        .Font.Color = vbBlue
    End With

    '// Make sure the report sheet is displayed
    wsReport.Activate

End Sub

有了这个数据

得到这个结果