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

【问题标题】：Excel Macro Copy Range Paste offset based on cell valueExcel宏复制范围粘贴偏移量基于单元格值
【发布时间】：2018-01-20 18:29:36
【问题描述】：

我有两张“数据”表——其中包含原始数据和“报告”——作为报告表。

报告表的前 5 行包含信息。
数据表有 6 列数据可用（SlNo 名称设计地点性别类别）
报告表只有前 5 列（SlNo Name Design 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

【问题讨论】：

这几乎可以工作。您正在复制整行：Worksheets("Data").Rows(x).Copy 搜索并查看如何复制行中的某些列。
恕我直言，您的代码不是很清楚 - 一些 cmets 和一致的缩进会有所帮助。我看不出它是如何产生你所说的结果的。例如，从第 2 行清除报告表（报告从第 6 行开始？）的循环看起来好像在引用它之前可能会清除包含类别的单元格 C5。然后，它根据数据列 4 检查类别，但您的问题暗示类别在数据列 6 中。关于您的问题的重点：整行已粘贴，恕我直言，仅仅是因为您正在复制整行。你应该只复制你需要的单元格范围。
正是你们俩...我在这一步中挣扎如何复制该范围...
如果您只想复制（例如）列 B:E，只需将您的 Copy 语句更改为仅复制列 B:E - 例如Worksheets("Data").Rows(x).EntireRow.Range("B1:E1").Copy 或 Worksheets("Data").Range("B" & x & ":E" & x).Copy。互联网上有很多很多复制某些单元格而不是整行的示例，我很惊讶您在找到所需内容之前设法找到了Rows(x).Copy。

标签： vba excel

【解决方案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

有了这些数据

得到这个结果

【讨论】：