delete rows vba vlookup

Question

下午好，我有一个包含3个表的excel，其中两个表是我从中提取数据的，一个表是导入数据的。我的宏遍历前两个表(h1和h2(，如果值不在第三个表(h3(中，它将复制h3中的数据。我想添加一个代码，这样，如果我在h1或h2中也进行了删除行的修改，而不是添加它们，那么宏也会在h3中删除它们。我不知道怎么做，你能帮我吗？

谢谢！

这是我的代码：

Option Explicit
Sub Copiar_Filas_2()
'optimizar macro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Definir objetos a utilizar'
Dim h1 As Variant, fila_h1 As Long, fila_h2 As Long, fila_h3 As Long, h2 As Variant, i As Integer, j As Integer, k As Integer, h3 As Variant
Set h1 = Sheets("Empleados")
Set h2 = Sheets("Formaciones")
Set h3 = Sheets("Resumen")
fila_h1 = Application.WorksheetFunction.CountA(h1.Range("A:A"))
fila_h2 = Application.WorksheetFunction.CountA(h2.Range("A:A"))
fila_h3 = Application.WorksheetFunction.CountA(h3.Range("A:A"))
'inicializo la variable j
'j = h3.Range("C" & Rows.Count).End(xlUp).Row 'selecciona la primera fila libre en col B
'comienzo el bucle
h3.Activate
For i = 2 To fila_h1
For k = 2 To fila_h2

'compruebo que el valor de h1 es igual a h2
If h1.Cells(i, 2).Value = h2.Cells(k, 1).Value Then

'compruebo que no estén los datos ya copiados
If IsError(Application.VLookup(h1.Cells(i, 1) & h2.Cells(k, 2), h3.Range("D1:D3500"), 1, False)) Then

'copio B y la pego
h2.Cells(k, 2).Copy Destination:=Sheets("Resumen").Cells(fila_h3 + 1, 3)
h1.Cells(i, 1).Copy Destination:=Sheets("Resumen").Cells(fila_h3 + 1, 1)
h1.Cells(i, 2).Copy Destination:=Sheets("Resumen").Cells(fila_h3 + 1, 2)

'aumento la variable j para que vaya a la siguiente fila de la hoja Resumen
fila_h3 = Application.WorksheetFunction.CountA(h3.Range("A:A"))

Application.CutCopyMode = False

End If
End If
Next k
Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub

Answer 1

试试这个。我对每一步都做了说明。

Option Explicit
Sub Copiar_Filas_2()
'Optimizar macro
Application.ScreenUpdating = False

'Definir objetos a utilizar'
Dim h1 As Worksheet, h2 As Worksheet, h3 As Worksheet
Dim rows_h1 As Long, rows_h2 As Long

Set h1 = ThisWorkbook.Sheets("Empleados")       'Use ActiveWorkbook if macro is run from a different file.
Set h2 = ThisWorkbook.Sheets("Formaciones")     'Use ActiveWorkbook if macro is run from a different file.
Set h3 = ThisWorkbook.Sheets("Resumen")         'Use ActiveWorkbook if macro is run from a different file.
rows_h1 = h1.Range("A" & Rows.Count).End(xlUp).Row  'To get number of rows in sheet.
rows_h2 = h2.Range("A" & Rows.Count).End(xlUp).Row  'To get number of rows in sheet.
rows_h3 = 3500                                      'To get number of rows in sheet.

h3.Range("A2:C" & rows_h3).ClearContents    'Clears h3 sheet A:C columns without the headers.

Dim cell_h1 As Range, cell_h2 As Range      'For looping
Dim cell_h3 As Range                        'For pasting
Dim find_str As String
Dim match_row As Long

Set cell_h3 = h3.Range("A2")                'Starting cell

'comienzo el bucle
For Each cell_h1 In h1.Range("A2:A" & rows_h1).Cells        'Loops through A column of h1 sheet.
For Each cell_h2 In h2.Range("A2:A" & rows_h2).Cells    'Loops through A column of h2 sheet.

'compruebo que el valor de h1 es igual a h2
If cell_h1.Offset(0, 1).Value2 = cell_h2.Value2 Then

find_str = cell_h1.Value2 & cell_h2.Value2          'Concatenates value in h1 and h2.
match_row = 0                                       'Initial value of match_row.

On Error Resume Next    'If match does not return any value.
'Check for match in D column of h3 sheet.
match_row = Application.WorksheetFunction.Match(find_str, h3.Range("D1:D3500"), 0)
On Error GoTo 0
If match_row > 0 Then
cell_h3.Value2 = cell_h1.Value2
cell_h3.Offset(0, 1).Value2 = cell_h1.Offset(0, 1).Value2
cell_h3.Offset(0, 2).Value2 = cell_h2.Offset(0, 1).Value2

'*** Use this instead, if you want to copy other things like formats and data-validation ***
'cell_h1.Copy: cell_h3.PasteSpecial xlPasteAll
'cell_h1.Offset(0, 1).Copy: cell_h3.Offset(0, 1).PasteSpecial xlPasteAll
'cell_h2.Offset(0, 1).Copy: cell_h3.Offset(0, 2).PasteSpecial xlPasteAll

Set cell_h3 = cell_h3.Offset(1, 0)              'Goes to next line.
End If
End If

Next cell_h2
Next cell_h1

Application.ScreenUpdating = True
End Sub