将数据从2张纸张以交错格式复制到单张纸张中

时间：2017-03-28 16:20:31

标签： excel vba excel-vba

我在2张纸上有2组数据，每张纸上有相同的列。 我想将两张数据集中的两组数据复制到第三张表中，但格式如下： - 

Sheet1
Name Age Gender
Mayur 23  M
Alex  24  M
Maria 25  F
April 19  F

Sheet2
Name Age Gender
Mayur 21  M
Maria 24  F
Alex  24  M
June  20  F


Sheet3
Name1 Name2 Age1 Age2 Gender1 Gender2
Mayur Mayur  23   21     M       M
Alex  Alex   24   24     M       M
Maria Maria  25   24     F       F
April        19          F 
      June        20             F

现在有一个主要列，即Name。此列永远不会为空。 两张纸张可能没有相同序列的数据。 两个工作表可能具有相同名称的不同条目。 任何一张表中都可能缺少一个名称

我编写了以下代码的完整代码： -

我从sheet2＆amp;中的sheet1中找到了名字。然后从表格到表格3复制该名称的相应条目。

如果在sheet2中找不到名称，那么它的数据将按原样复制，如上所示＆amp;最后，如果片材中没有任何名称，则在sheet1中搜索sheet2中的名称。这些条目将复制到sheet3中。

现在搜索部分的性能非常好，但复制部分需要花费很多时间。

我也尝试过其他复制数据的方法，但没有一种方法运行得非常快。 在实际数据中，有超过200列＆amp;数百万行。 整个过程持续超过6-7个小时。

任何人都可以让我知道任何其他更快的方法来实现这一目标。 即使这可以将时间从7小时减少到1小时或2小时仍然很好。

另外，我需要强调一下，当从两张纸上复印时，如果数据不匹配，可以通过更改单元格颜色来做到这一点。

以下是代码

Sub findUsingArray()
Dim i As Long
Dim j As Variant
Dim noOfColumnsA As Integer
Dim maxNoOfColumns As Integer
Dim noOfRowsA As Long
Dim noOfRowsB As Long
Dim arrayColumnA() As Variant
Dim arrayColumnB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim primaryKeyColumn As Integer
Dim result As Long

Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")

noOfColumnsA = sheet1.Cells(1, Columns.Count).End(xlToLeft).Column

maxNoOfColumns = noOfColumnsA * 2

noOfRowsA = sheet1.Cells(Rows.Count, 1).End(xlUp).Row

noOfRowsB = sheet2.Cells(Rows.Count, 1).End(xlUp).Row

'createHeader maxNoOfColumns Used to create header in 3rd sheet

primaryKeyColumn = 1

ReDim arrayColumnA(noOfRowsA)
ReDim arrayColumnB(noOfRowsB)


arrayColumnA = sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn))

arrayColumnB = sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn))


    result = 2

        For i = 2 To noOfRowsA
            j = Application.Match(arrayColumnA(i, 1), sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)), 0)

                If Not IsError(j) Then
                    result = copyInaRowUsingArray(i, result, j, maxNoOfColumns)
                Else
                    result = copyMissingRow(1, i, result, maxNoOfColumns)
                End If
        Next i

    For i = 2 To noOfRowsB
        j = Application.Match(arrayColumnB(i, 1), sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)), 0)

        If IsError(j) Then
            result = copyMissingRow(2, i, result, maxNoOfColumns)
        End If

    Next i
End Sub

Function copyInaRowUsingArray(sheet1Index As Long, newRowIndex As Long, sheet2index As Variant, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
Dim rowColoured As Boolean

j = 1

Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Set sheet3 = ThisWorkbook.Sheets("Sheet3")


 arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheet1Index, 1), sheet1.Cells(sheet1Index, noOfColumns)).Value))
 arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheet2index, 1), sheet2.Cells(sheet2index, noOfColumns)).Value))

 rowColoured = False

With sheet3

    For i = 1 To noOfColumns

        valueA = arrayA(j)
        If Not valueA = "" Then
            .Cells(newRowIndex, i).Value = valueA
        End If
        i = i + 1

        valueB = arrayB(j)
        If Not valueB = "" Then
            .Cells(newRowIndex, i).Value = valueB
        End If

        If Not StrComp(CStr(valueA), CStr(valueB)) = 0 Then
            If Not rowColoured Then
                .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 35
                rowColoured = True
            End If

            .Cells(newRowIndex, i).Interior.ColorIndex = 34
            .Cells(newRowIndex, i - 1).Interior.ColorIndex = 34
        End If

        j = j + 1

    Next i

    copyInaRowUsingArray = newRowIndex + 1
End With
End Function

Function copyMissingRow(sheetNo As Integer, sheetIndex As Long, newRowIndex As Long, noOfColumns As Integer)

Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet

j = 1

Set sheet3 = ThisWorkbook.Sheets("Sheet3")

With sheet3
    If sheetNo = 1 Then
        Set sheet1 = ThisWorkbook.Sheets("Sheet1")

        ReDim arrayA(noOfColumns)
        arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheetIndex, 1), sheet1.Cells(sheetIndex, noOfColumns)).Value))

        For i = 1 To noOfColumns

            valueA = arrayA(j)
            If Not valueA = "" Then
                .Cells(newRowIndex, i).Value = valueA
            End If
            i = i + 1
            j = j + 1

        Next i

        .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 46

    Else

        Set sheet2 = ThisWorkbook.Sheets("Sheet2")

        ReDim arrayB(noOfColumns)
        arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheetIndex, 1), sheet2.Cells(sheetIndex, noOfColumns)).Value))

        For i = 1 To noOfColumns

            i = i + 1

            valueB = arrayB(j)
            If Not valueB = "" Then
                .Cells(newRowIndex, i).Value = valueB
            End If

            j = j + 1

        Next i

        .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 3

    End If

     copyMissingRow = newRowIndex + 1

End With
End Function

1 个答案:

答案 0 :(得分：2)

根据其中一条评论，字典应该有助于做你以后的事情。这里使用的字典从表（2）中保存名称作为键，相应的行作为值保存。

int A[n][n];
for(int i=0; i<n;i++) {
    for(int j=0;j<n;j++) {
        int x;
        cin >> x;
        A[i][j] = x;
    }
}
int sumLine = 0;
for(int k=0;k<n;k++) {
    sumLine += A[k][0];
}

＆＃39; InterLeaveRows＆＃39;的第一个循环子程序通过遍历Sheet（2）中的所有条目来填充字典。接下来的两行将标题写出到表（3）。然后第二个循环将所有值写入Sheet（3），这些值在字典中（即在Sheet（1）和Sheet（2）中）或仅在Sheet（1）中;请注意，这样写入Sheet（3）的字典中的条目将从字典中删除。最后一个循环写出保留在字典中的键/值对。这些是仅在Sheet（2）中的条目。

相关问题
最新问题