我已经编写了一个代码来找出两张纸之间的差异，差异将粘贴在一张新纸上。现在我在表格中也需要这些列名。因为我是Macros的初学者。我无法做到这一点。请帮我。在此先感谢。
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count > 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
ws1.Cells(r, c).Interior.ColorIndex = 12
ws1.Cells(r, c).Copy
ws2.Cells(r, c).Interior.ColorIndex = 12
ws2.Cells(r, c).Copy
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.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
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
' CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
' Workbooks("Compare Data Using Macro -New.xlsm").Worksheets("Sheet2")
End Sub
答案 0 :(得分：0)
基本上：
ws1.Activate
Range(Cells(1, 1), Cells(1, lc1)).Copy
[your destination worksheet].Range("A1").PasteSpecial Paste:=xlPasteAll
但是......你在哪里定义了ws1和ws2？目标表位于其他工作簿中...您在新工作表中将数据粘贴到哪里？
前段时间我写了一个宏来做到这一点：
' Macro: ActualizarDatos()
Sub ActualizarDatos()
Dim num_sheets As Integer
Dim last_row_s1, last_col_s1 As Long
Dim last_row_s2, last_col_s2 As Long
Dim lookup_range As Range
Dim my_index, my_target_index As Variant
num_sheets = ActiveWorkbook.Sheets.Count
' Verifica el numero de hojas
If num_sheets >= 2 Then
If num_sheets = 2 Then
' Añadir nueva hoja al final
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULTADO"
End If
' Para determinar el tamaño de las hojas 1 y 2
last_row_s1 = ActiveWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
last_col_s1 = ActiveWorkbook.Sheets(1).Range("a1").End(xlToRight).Column
last_row_s2 = ActiveWorkbook.Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
last_col_s2 = ActiveWorkbook.Sheets(2).Range("a1").End(xlToRight).Column
' Copia los datos de la Hoja-1 en la Hoja-3 de resultado
Sheets(1).Activate
Range(Cells(1, 1), Cells(last_row_s1, last_col_s1)).Copy
Worksheets(3).Range("A1").PasteSpecial Paste:=xlPasteAll
'Worksheets(3).Range("A1").PasteSpecial Paste:=xlPasteFormats
'Worksheets(3).Range("A1").Paste
Sheets(2).Activate
Set lookup_range = Range(Cells(1, 1), Cells(last_row_s2, 1))
' Recorre los indices (columna A) de la Hoja-1 y busca las coincidencias en
' la Hoja-2
For num_row = 2 To last_row_s1
my_index = Sheets(1).Cells(num_row, 1).Value
my_target_index = Application.Match(my_index, lookup_range, 0)
If Not IsError(my_target_index) Then
' Encontrada la coincidencia de índices se recorren las filas de
' encabezados de columnas (fila 1) para buscar coincidencias.
For num_col = 2 To last_col_s1
title_origin = Sheets(1).Cells(1, num_col)
title_target_index = Application.Match(title_origin, _
Sheets(2).Range(Cells(1, 1), Cells(1, last_col_s2)), 0)
If Not IsError(title_target_index) Then
' Encontrada la coincidencia de encabezados de columna
' comprobar si el valor de la celda es distinto y no Null
' copiar a hoja 3 llamando a subrutina ActualizarCelda
ActualizarCelda Sheets(3).Cells(num_row, num_col), _
Sheets(2).Cells(my_target_index, title_target_index)
End If
Next num_col
End If
Next num_row
'ActiveSheet.Range("a1", Range("a1").End(xlDown).End(xlToRight)).Select
' Debug purpose
' MsgBox "HOJA-1. Número de Filas: " & last_row_s1 & vbNewLine & "Número de Columnas: " & last_col_s1
' MsgBox "HOJA-2. Número de Filas: " & last_row_s2 & vbNewLine & "Número de Columnas: " & last_col_s2
Else
MsgBox ("ERROR! Se necesita un mínimo de 2 hojas")
End If
End Sub
' Subrutina privada de ActualizarDatos()
' parametros:
' celdaOrigen; tipo Range, dato de la hoja-3 original
' celdaDestino; tipo Range, dato de la hoja-2
' verifica si el contenido de la celda destino es diferente a la celda origen
' y en ese caso actualiza su valor y cambia el fondo a Amarillo.
Private Sub ActualizarCelda(ByVal celdaOrigen, celdaDestino As Range)
If (Not celdaDestino.Value = Empty) And UCase(celdaOrigen.Value) <> UCase(celdaDestino.Value) Then
celdaDestino.Copy
celdaOrigen.PasteSpecial Paste:=xlPasteAll
' celdaOrigen.Value = UCase(celdaDestino.Value) DESCARTADO POR NO CONSERVAR FORMATO FECHA
celdaOrigen.Interior.ColorIndex = 6 ' Formato fondo de celda Amarillo.
' MsgBox celdaOrigen.Value
End If
End Sub
答案 1 :(得分：0)
检查[Cells(r, c).Formula = ws1.Cells(r, c)]行。这会将工作表1的列名复制到新工作表中。
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
Cells(r, c).Formula = ws1.Cells(r, c)
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
ws1.Cells(r, c).Interior.ColorIndex = 12
ws1.Cells(r, c).Copy
ws2.Cells(r, c).Interior.ColorIndex = 12
ws2.Cells(r, c).Copy
End If
Next r