Question

我有两张“数据” - 有原始数据和“报告” - 作为报表。

报告表前5行有信息。
数据表有6列可用数据（SlNo Name Desig Place性别类别）
报告表只有前5列（SlNo Name Desig Place性别）
报表单范围C5是下拉框（数据表的“类别”列中的列表）。

因此，根据此C5值，从数据表中获取详细信息并粘贴到报告表中。

我尝试了以下代码，但是当我只想粘贴名称，设计，地点，偏移和循环中的性别详细信息时，它会粘贴整行...

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

使用此数据

获得此结果

Excel宏复制范围根据单元格值粘贴偏移量

1 个答案: