比较不同列顺序的两个工作表 [英] Comparing two worksheets with different column order
问题描述
我正在尝试比较Excel中的两个工作表,以使用vba查找新的/更新的记录。
(假设工作表1是旧的,工作表2有潜在的新的/更新的条目)
I'm trying to compare two worksheets in excel to find new/updated records using vba. (assume worksheet 1 is old, and worksheet 2 has the potential new/updated entries)
这些工作表有非常相似的信息存储在每个,只是在一个不同的订单。
These sheets have very similar information stored in each, just in a different order.
例如:
工作表1在列E中有街道地址,而工作表2在列H中有街道地址。还有许多其他列这个。
For example: Worksheet 1 has Street Address in Column E whereas Worksheet 2 has the street Address in Column H. There are many other columns like this.
我不太确定从哪里开始。我试图通过剪切和插入来重新排列第二张表中的列,以匹配那些第一张的列,但是这些列非常快速。
I'm not really sure where to start. I tried to rearrange the columns in the second sheet by cutting and inserting to match those of the first, but that got out of hand very quickly.
另外,如果它的一个新记录,需要附加到数据的末尾。
Also, if its a new record, it needs be appended to the end of the data.
推荐答案
**更新以允许定义键列。只需将'iKeyCol = 2'行更改为所需的列。
**Updated to allow defining the 'key' column. Just change the line 'iKeyCol = 2' to the desired column.
这是一些尝试的代码。我太懒了,重新修改了我正在使用的所有代码,所以有些可能是额外的。确保您的工作簿
1.至少有三张(名称Sheet1,Sheet2,NewSheet)
2.具有Sheet1和Sheet2
3. Col1必须在两张表中匹配
4.列数必须在两张表中匹配。
其他col1,其他列可以按任何顺序。
Here is some code to try. I was too lazy to rework all the code I was using, so some of this may be extra for you. Make sure your workbook 1. Has at least three sheets (names 'Sheet1, Sheet2, NewSheet') 2. Has column headers for Sheet1 & Sheet2 3. Col1 must match in both sheets 4. Column count must match in both sheets. Other that col1, other columns can be in any order.
将代码粘贴到新模块中并执行。
Paste the code into a new module and the execute.
如果您有问题,请通知我。
Let me know if you have a problem.
Option Explicit
' This module will compare differences between two worksheets.
Sub Compare106thWorksheets()
Dim iKeyCol As Integer
'>>>> CHANGE THE FOLLOWING LINE TO IDENTIFY THE KEY COLUMN
iKeyCol = 2
Dim i, i2, i3 As Integer
Dim iRow As Long
Dim iR1, iR2 As Long
Dim iC1, iC2 As Integer
Dim iColMap(30) As Integer
Dim iCol1, iCol2 As Integer
Dim LastRow1 As Long, LastRow2 As Long
Dim LastCol1 As Integer, LastCol2 As Integer
Dim MaxRow1 As Long
Dim MaxCol1 As Integer
Dim sFld1 As String, sFld2 As String
Dim sFN1, sFN2 As String
Dim rptWB As Workbook
Dim DiffCount As Long
Dim iLastRow, iLastColumn As Integer
Dim strDeleted, strInserted As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wsChg As Worksheet
Dim iCHGRows As Long
Dim iCHGCols As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Set wsChg = ThisWorkbook.Worksheets("NewSheet")
With ws1.UsedRange ' Get used range of Sheet1
LastRow1 = .Rows.Count
LastCol1 = .Columns.Count
End With
With ws2.UsedRange ' Get used range of Sheet1
LastRow2 = .Rows.Count
LastCol2 = .Columns.Count
End With
With wsChg.UsedRange ' Get used range of Sheet1
iCHGRows = .Rows.Count
iCHGCols = LastCol1
End With
MaxRow1 = LastRow1
MaxCol1 = LastCol1
Debug.Print ws1.Name & " has " & LastRow1 & " rows and " & LastCol1 & " columns."
Debug.Print ws2.Name & " has " & LastRow2 & " rows and " & LastCol2 & " columns."
If MaxRow1 < LastRow2 Then MaxRow1 = LastRow2
If MaxCol1 < LastCol2 Then MaxCol1 = LastCol2
' Build a column map. Require both sheets to have the same names - but different order.
For i = 1 To 30
iColMap(i) = 0
Next i
For iC1 = 1 To MaxCol1
For i = 1 To LastCol2
If ws1.Cells(1, iC1) = ws2.Cells(1, i) Then
iColMap(iC1) = i
Exit For
End If
Next i
Next iC1
' Check if any column headers failed to match.
For i = 1 To MaxCol1
If iColMap(i) = 0 Then
MsgBox "Column named '" & ws1.Cells(1, i) & " not found in Sheet2. Please correct and start again."
GoTo Exit_Code
End If
Next i
strDeleted = "": strInserted = ""
iR2 = 1
DiffCount = 0
For iR1 = 1 To MaxRow1
If ws1.Cells(iR1, iKeyCol) <> ws2.Cells(iR2, iKeyCol) Then ' Cell is different - is it an ADD or Delete?
Debug.Print "Row: " & iR1 & vbTab & ws1.Cells(iR1, iKeyCol) & vbTab & "versus: " & ws2.Cells(iR2, iKeyCol)
sFld1 = Trim(ws1.Cells(iR1, iKeyCol).FormulaLocal)
sFld2 = Trim(ws2.Cells(iR2, iKeyCol).FormulaLocal)
If sFld1 < sFld2 Then
Debug.Print "Deleted Row " & ws1.Cells(iR1, iKeyCol)
DiffCount = DiffCount + 1
wsChg.Cells(DiffCount, iKeyCol) = "Deleted:"
wsChg.Cells(DiffCount, 2) = ws1.Cells(iR1, iKeyCol)
strDeleted = strDeleted & ws1.Cells(iR1, iKeyCol) & vbCrLf
iCHGRows = iCHGRows + 1
wsChg.Cells(iCHGRows, 1) = Now()
For i = 1 To LastCol1
wsChg.Cells(iCHGRows, i + 1) = ws1.Cells(iR1, i)
Next i
ws1.Rows(iR1).EntireRow.Delete
iR1 = iR1 - 1
GoTo Its_OK
ElseIf sFld1 > sFld2 Then
Debug.Print "Inserted Row " & ws2.Cells(iR1, iKeyCol)
Debug.Print "R1: " & iR1 & " R2: " & iR2 & vbTab & ws1.Cells(iR1, iKeyCol) & vbTab & "versus: " & ws2.Cells(iR2, iKeyCol)
DiffCount = DiffCount + 1
strInserted = strInserted & ws2.Cells(iR2, iKeyCol) & vbCrLf
ws1.Rows(iR1).EntireRow.Insert
For i = 1 To LastCol1
ws1.Cells(iR1, i) = ws2.Cells(iR2, iColMap(i))
Next i
iR2 = iR2 + 1
GoTo Its_OK
Else
iR2 = iR2 + 1
End If
Else ' Values are the same
iR2 = iR2 + 1
End If
Its_OK:
Next iR1
Debug.Print "Deleted:"
Debug.Print strDeleted
Debug.Print "------------------------------------------------------------------"
Debug.Print "Inserted:"
Debug.Print strInserted
Debug.Print "------------------------------------------------------------------"
For iRow = 2 To LastRow2
Application.StatusBar = "Comparing cells " & Format(iCol1 / MaxCol1, "0 %") & "..."
For iCol1 = 1 To LastCol1
iCol2 = iColMap(iCol1)
sFld1 = ""
sFld2 = ""
On Error Resume Next
sFld1 = ws1.Cells(iRow, iCol1).FormulaLocal
sFld2 = ws2.Cells(iRow, iCol2).FormulaLocal
On Error GoTo 0
If sFld1 <> sFld2 Then
Debug.Print "Row: " & iRow & vbTab & ws1.Cells(iRow, iCol1) & vbTab & "versus: " & ws2.Cells(iRow, iCol2)
DiffCount = DiffCount + 1
wsChg.Cells(DiffCount, 1) = ws1.Cells(iRow, iKeyCol)
wsChg.Cells(DiffCount, 2) = ws1.Cells(1, iCol1)
wsChg.Cells(DiffCount, 3) = sFld1
wsChg.Cells(DiffCount, 4) = sFld2
ws1.Cells(iRow, iCol1).FormulaLocal = ws2.Cells(iRow, iCol2).FormulaLocal
End If
Next iCol1
Next iRow
wsChg.Activate
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(MaxRow1, MaxCol1))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
Exit_Code:
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
这篇关于比较不同列顺序的两个工作表的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!