如何使用Excel VBA将列名从一张表复制到另一张表

Question

我已经编写了一个代码来找出两张表之间的差异，并将差异粘贴到新表中。现在我也需要这些列名称。因为我是宏的初学者。我无法做到这一点。请帮帮我。提前致谢。

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 

Answer 1

基本上是：

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 

Answer 2

检查线路[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