两个不同工作表中的 2 列转移到第三列答案

【问题标题】：2 columns in two different sheets transferred to a third column两个不同工作表中的 2 列转移到第三列
【发布时间】：2020-06-02 16:12:49
【问题描述】：

我目前正在处理一个由 3 张纸组成的 Excel 文件。三张纸由以下组成，首先是“Datenquelle”，其次是“Datenunterschied”，第三是“Daten”。

所有三个工作表都包含相同的列名和相似的数据。我想通过 VBA 宏将“Datenquelle”和“Daten”中数据的差异突出显示到“Datenunterschied”工作表中。

参考点应该是“标识符”列。

如您所见，“数据”表包含四个具有以下标识符编号的数据集：

6257 - 6258 - 6259 - 6260

“Datenquelle”表包含六个标识符号：

6257 - 6258 - 6259 - 6260 - 6261 - 6268

目标是所有未包含在工作表“Daten”中但包含在“Datenquelle”中的数据集都应通过 VBA 宏放入工作表“Datenunterschied”中。在我的示例中，那些将是标识符“6261”和“6268”之后的数据集。数据集“6261”和“6268”的整个单元格应转移到“Datenunterschied”。

我尝试关注宏，但没有产生正确的结果。

Sub Unterschied()
Dim CompareRange As Object, x As Object, y As Object
Dim lastRow As Integer

Set CompareRange = Sheets("Datenquelle").Range("H2:H" & Sheets("Datenquelle").Cells(Rows.Count,  _
9).End(xlUp).Row)

    For Each x In Sheets("Daten").Range("H2:H" & Sheets("Daten").Cells(Rows.Count, 9).End(xlUp). _
Row)
        For Each y In CompareRange

        If y <> x Then
            lastRow = Sheets("Datenunterschied").Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets("Datenunterschied").Cells(lastRow, 9).Value = x.Value
            Sheets("Datenunterschied").Cells(lastRow, 10).Value = x.Offset(0, 1).Value
            Sheets("Datenunterschied").Cells(lastRow, 11).Value = x.Offset(0, 2).Value
            Sheets("Datenunterschied").Cells(lastRow, 8).Value = x.Offset(0, -1).Value
            Sheets("Datenunterschied").Cells(lastRow, 7).Value = x.Offset(0, -2).Value
            Sheets("Datenunterschied").Cells(lastRow, 6).Value = x.Offset(0, -3).Value
            Sheets("Datenunterschied").Cells(lastRow, 5).Value = x.Offset(0, -4).Value
            Sheets("Datenunterschied").Cells(lastRow, 4).Value = x.Offset(0, -5).Value
            Sheets("Datenunterschied").Cells(lastRow, 3).Value = x.Offset(0, -6).Value
            Sheets("Datenunterschied").Cells(lastRow, 2).Value = x.Offset(0, -7).Value
            Sheets("Datenunterschied").Cells(lastRow, 1).Value = x.Offset(0, -8).Value
        End If
        Next y
    Next x
End Sub

我在这里提供了数据：

https://www.herber.de/bbs/user/137783.xlsm

问候卡尼姆

【问题讨论】：

标签： excel vba

【解决方案1】：

很遗憾，如果不下载您的 Excel 表格，您的问题很难理解。我相信我明白你想要什么，我会给你一个一般性的答案，你必须根据你的个人情况进行调整。我还考虑编写与您的代码类似的代码，但决定以更可重用的方式重新编写它。首先让我们看看如何正确处理不同的工作表。查看this topic 和this topic。基本上首先我们要使用Option Explicit。然后我们想将我们的工作簿和工作表声明为变量并以安全的方式处理它们。

所以我们的第一步：

Option Explicit

Sub Difference()
    Dim wb As Workbook
    Set wb = ThisWorkbook

    Dim ws_data As Worksheet
    Set ws_data = wb.Sheets("Daten")

    Dim ws_dataSource As Worksheet
    Set ws_dataSource = wb.Sheets("Datenquelle")

    Dim ws_dataDiff As Worksheet
    Set ws_dataDiff = wb.Sheets("Datenunterschied")
End Sub

现在，您在 ws_dataSource 中拥有在 ws_data 中找不到的带有标识符的列。因此，我们检查两张纸是否有不同的标识符。我将采用您的方法，声明在哪里寻找它们，然后循环遍历它们。

    Dim rSource As Range, rData, rDiff As Range
    Set rSource = ws_dataSource.Range("A1:F1")  'this assumes six columns starting at A1. You will need to adjust the A1:F1 part
    Set rData = ws_data.Range("A1:F1")          'again, your range will vary
    Set rDiff = ws_dataDiff.Range("A1:ZZ1")


    Dim x, y As Range 'these are the cell variables we will use to loop through the ranges. you are using object x and y for this task

    For Each x In rSource
        Dim currentIdentifier As String
        currentIdentifier = x.Value 'value to look for in data range
        Dim foundMatch As Boolean 'setup marker that tells us if no match has been found
        foundMatch = False

        For Each y In rData
            If currentIdentifier = y.Value Then
                foundMatch = True       'this columns needs not to be copied as we have found it in both worksheets
                Exit For
            End If
        Next y

        If Not foundMatch Then          'only when y has been looped through without finding a match
            'here comes the bit where we actually copy the data
            Debug.Print currentIdentifier
        End If
    Next x

最后一点我没时间了，但是有很多资源可以让人们学习如何将列从一张纸复制到另一张纸。看看here: （归结为采用x 的范围并使用copy 方法。x.copy NewColumn

表达式.复制（目标）

【讨论】：

感谢您迄今为止的帮助和改进我的代码。我已经相应地调整了我的代码，但是在执行代码时，什么也没发生。我将重新发布代码，您可以再看一下吗？因为，我不明白，为什么它不起作用。

【解决方案2】：

Option Explicit

Sub Difference()
    Dim wb As Workbook
    Set wb = ThisWorkbook

    Dim ws_data As Worksheet
    Set ws_data = wb.Sheets("Daten")

    Dim ws_dataSource As Worksheet
    Set ws_dataSource = wb.Sheets("Datenquelle")

    Dim ws_dataDiff As Worksheet
    Set ws_dataDiff = wb.Sheets("Datenunterschied")


Dim rSource As Range, rData, rDiff As Range
Dim lastRow As Long

    Set rSource = ws_dataSource.Range("A2:K2") 'this assumes six columns starting at A1. You will need to adjust the A1:F1 part
    Set rData = ws_data.Range("A2:K2")         'again, your range will vary
    Set rDiff = ws_dataDiff.Range("A2:K2")


    Dim x, y As Range 'these are the cell variables we will use to loop through the ranges. you are using object x and y for this task

    For Each x In rSource
        Dim currentIdentifier As String
        currentIdentifier = x.Value 'value to look for in data range
        Dim foundMatch As Boolean 'setup marker that tells us if no match has been found
        foundMatch = False

        For Each y In rData
            If currentIdentifier = y.Value Then
                foundMatch = True       'this columns needs not to be copied as we have found it in both worksheets
                Exit For
            End If
        Next y

        If Not foundMatch Then          'only when y has been looped through without finding a match
            lastRow = Sheets("Datenunterschied").Cells(Rows.Count, 1).End(xlUp).Row + 1
            x.Copy (ws_dataDiff.Range("A2:K2")) 'here comes the bit where we actually copy the data
            Debug.Print currentIdentifier
        End If
    Next x
End Sub

【讨论】：

稍后我会仔细查看，但使用x.copy，您只会复制x，这只是标识符单元格之一。您需要先构建一个范围对象，其中包含 x 列并复制该列。我看到您已经找到了lastRow，这意味着您快到了（即使您没有查看 x 列而是查看“A”列）。只需尝试创建所述范围并复制该范围，然后您就应该拥有它
我创建了一个对象，但该对象随后将引用范围 - 我猜。你能举个例子说明你的意思吗，因为我还是不明白。
@MertY 我想让你知道，我找到了解决问题的方法。您的代码示例帮助我完成了它。我将在答案中提供我的解决方案。非常感谢您的帮助。
Hineyamata 很高兴听到这个消息！抱歉，我没有跟进最后一点，但我相信您通过提出自己的解决方案学到了更多！我很想看看你最后是怎么做到的 :-)

【解决方案3】：

问题的解决方法如下：

Sub Difference()

Dim lastRow As Long
Dim x, y As Object 'Cells which will loop through, but declared as objects.


    For Each x In Sheets("Datenquelle").Range("I2:I" & Sheets("Datenquelle").Cells(Rows.Count, 9).End(xlUp).Row)
        Dim foundMatch As Boolean 'setup marker that tells us if no match has been found
        foundMatch = False

        For Each y In Sheets("Daten").Range("I2:I" & Sheets("Daten").Cells(Rows.Count, 9).End(xlUp).Row)
            If x.Value = y.Value Then
                foundMatch = True       
                Exit For
            End If
        Next y

        If Not foundMatch Then          'only when y has been looped through without finding a match
            lastRow = Sheets("Datenunterschied").Cells(Rows.Count, 9).End(xlUp).Row + 1
            Sheets("Datenunterschied").Cells(lastRow, 9).Value = x.Value ' Copying and setting the data in last available free row
            Debug.Print x.Value
        End If
    Next x
End Sub

【讨论】：