将两张表中的数据按指定关键字合并的VBA实现

将两张表中的数据按指定关键字合并的VBA实现

 

                                               ——Author:东园公

实现方法如下：

 

1、  将表1按指定关键字“款号、颜色、尺码”排序，如果存在关键字相同的行项目，那么按关键字数量汇总在同一行项目中；

2、  同样将表2中的数据按1中方法，按关键字数量汇总在同一行项目中；

3、      表1与表2合并，数据放在汇总表中，如果表2中的数据在表1中没有匹配到，那么将以红色字体列出。

 

要注意事项有:

 

三个表:

 

表1,该名称不能改变,用于存储第一张表的数据信息;

 

表2,该名称不能改变,用于存储第二张表的数据信息;

 

汇总:该名称不能改变,用于存储第一张表与第二张表通过匹配后的数据信息;

 

表1第一行为标题(款号 颜色 尺码 数量) ,从第二行开始为数据行,其中的数据可

 

不必做处理(包括:款号 颜色 尺码相同的行项目,程序会自动帮你把相同行项目合

 

并,但数量会累加,同时也会帮你排序);

 

 

表2表一行为标题(款号 颜色 尺码 数量) ,从第二行开始为数据行,其中的数据可

 

不必做处理(包括:款号 颜色 尺码相同的行项目,程序会自动帮你把相同行项目合

 

并,但数量会累加,同时也会帮你排序);

 

 

 

汇总表,只要点击汇总按钮,数据就会显示出来,按照相同款号 颜色 尺码 显示表1,

 

表2中各自的数量,最后汇总;如果表1中的数据与表2中的数据没有匹配成功时,也就

 

是没有相同项时,也会显示出来;如果表2中的数据在表1中没有匹配项,那么以红色

 

分开显示.

 

图示：

 

合并后的数据：

 

 

VBA代码：

 

 

 

 

Sub comp()

   Dim totaLastRows As Integer

   Dim tab1LastRows As Integer

   Dim tab2LastRows As Integer

   Dim i, j, k As Integer

   Dim mark As String

   Dim count As Double

  

   On Error Resume Next

  

   Application.ScreenUpdating = False

  

   '清空汇总表中所有内容,字体颜色,合并单元格

   Sheets("汇总").Activate

   totaLastRows = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.count

   With Range("A1:" & "F" & totaLastRows).Selection

        .ClearContents

        .UnMerge

        .Font.ThemeColor = 2

        .TintAndShade = 0

   End With

  

   '写表头

   Cells(1, 1).Value = "款号"

   Cells(1, 2).Value = "颜色"

   Cells(1, 3).Value = "尺码"

   Cells(1, 4).Value = "表1"

   Cells(1, 5).Value = "表2"

   Cells(1, 6).Value = "汇总"

  

   '将表1中所有内容按款号,颜色,尺码排序

   Sheets("表1").Activate

   tab1LastRows = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.count

  

   Sheets("表1").Range("A2" & ":" & "D" & tab1LastRows).Sort Key1:=Worksheets("表1").Range("A2"), _

                                              Key2:=Worksheets("表1").Range("B2"), _

                                              Key3:=Worksheets("表1").Range("C2")

 

  '将排序后的数据,如果同存关键字一样的行,那么合并行,将数量累加

   For i = 2 To tab1LastRows Step 1

      For j = 2 To tab1LastRows Step 1

        If i <> j Then

          If Range("A" & i) = Range("A" & j) And _

             Range("B" & i) = Range("B" & j) And _

             Range("C" & i) = Range("C" & j) Then

            

             Range("D" & i) = Range("D" & i) + Range("D" & j)

             Rows(j).Delete

             tab1LastRows = tab1LastRows - 1

          End If

        End If

      Next j

   Next i

  

   '将表2中所有内容按款号,颜色,尺码排序

   Sheets("表2").Activate

   tab2LastRows = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.count

  

   Sheets("表2").Range("A2" & ":" & "D" & tab2LastRows).Sort Key1:=Worksheets("表2").Range("A2"), _

                                              Key2:=Worksheets("表2").Range("B2"), _

                                              Key3:=Worksheets("表2").Range("C2")

   

   '将排序后的数据,如果同存关键字一样的行,那么合并行,将数量累加

   For i = 2 To tab2LastRows Step 1

      For j = 2 To tab2LastRows Step 1

        If i <> j Then

          If Range("A" & i) = Range("A" & j) And _

             Range("B" & i) = Range("B" & j) And _

             Range("C" & i) = Range("C" & j) Then

            

             Range("D" & i) = Range("D" & i) + Range("D" & j)

             Rows(j).Delete

             tab2LastRows = tab2LastRows - 1

          End If

        End If

      Next j

   Next i

  

   '将表1和表2中按指定关键字合并,并将数量相加放在汇总一栏

   Sheets("汇总").Activate

   For i = 2 To tab1LastRows Step 1

      Range("A" & i) = Sheets("表1").Range("A" & i)

      Range("B" & i) = Sheets("表1").Range("B" & i)

      Range("C" & i) = Sheets("表1").Range("C" & i)

      Range("D" & i) = Sheets("表1").Range("D" & i)

       

      For j = 2 To tab2LastRows Step 1

         If Sheets("表1").Range("A" & i) = Sheets("表2").Range("A" & j) And _

            Sheets("表1").Range("B" & i) = Sheets("表2").Range("B" & j) And _

            Sheets("表1").Range("C" & i) = Sheets("表2").Range("C" & j) Then

            

            Range("E" & i) = Sheets("表2").Range("D" & j)

            Range("F" & i) = Sheets("表1").Range("D" & i) + Sheets("表2").Range("D" & j)

            Sheets("表2").Range("AH" & j) = "X"

         End If

      Next j

    Next i

     

     

    '以下是表2在表1中没有匹配的数据

    k = tab1LastRows + 2

    mark = ""

    For j = 2 To tab2LastRows Step 1

       If Sheets("表2").Range("AH" & j) <> "X" Then

          k = k + 1

          Range("A" & k) = Sheets("表2").Range("A" & j)

          Range("B" & k) = Sheets("表2").Range("B" & j)

          Range("C" & k) = Sheets("表2").Range("C" & j)

          Range("E" & k) = Sheets("表2").Range("D" & j)

         

          Range("A" & k & ":E" & k).Font.ColorIndex = 3

          mark = "X"

       End If

       Sheets("表2").Range("AH" & j).Value = ""

    Next j

    If mark = "X" Then

       k = tab1LastRows + 2

       Range("A" & k) = "以下是表2在表1中没有匹配的数据"

       Range("A" & k & ":F" & k).Font.ColorIndex = 3

       Range("A" & k & ":F" & k).MergeCells = True

    End If

   

    Application.ScreenUpdating = True

End Sub

 

 

 

文件:	两表对比汇总表(1).zip
大小:	16KB
下载:	下载