基於單元格值的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

有了這個數據

得到這個結果