如何使用Excel VBA将列名称从一个工作表复制到另一个工作表

I have wrote a code to find out the differences between two sheets and differences will be pasted in a new sheet. Now I need those column names as well in the sheet. As i am beginner to Macros. I couldn't do that. Please help me. Thanks in Advance.

我写了一个代码来找出两张纸之间的差异,差异将粘贴在一张新纸上。现在我在表格中也需要这些列名。因为我是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

2 个解决方案

#1

Basically:

ws1.Activate
Range(Cells(1, 1), Cells(1, lc1)).Copy
[your destination worksheet].Range("A1").PasteSpecial Paste:=xlPasteAll

But... Where you've defined ws1 and ws2? The destination sheet is in other workbook... Where are you pasting data in the new sheet?

但是......你在哪里定义了ws1和ws2?目标表位于其他工作簿中...您在新工作表中粘贴数据的位置是什么?

Some time ago I wrote a macro to do that:

前段时间我写了一个宏来做到这一点:

' 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

#2

Check the line [Cells(r, c).Formula = ws1.Cells(r, c)]. this will copy the column names of sheet 1 to your new sheet.

检查行[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