Удаление пустых строк в Excel после их копирования на новый рабочий лист с использованием VBA

Question

Я успешно написал сценарий VBA для Excel, который проверяет, содержит ли столбец A конкретную запись (в данном случае: 2016), а затем копирует всю строку в новый рабочий лист.

Единственная проблема заключается в том, что он копирует строки в то же самое положение, что и на исходном листе. Из-за этого я получаю пустые строки между ними. Я хотел бы, чтобы макрос либо удалял эти пустые строки сразу после их копирования, либо копировал строки один за другим в новый рабочий лист.

Sub CopyRow() 

Application.ScreenUpdating = False 

Dim x As Long 
Dim MaxRowList As Long 
Dim S As String 
Dim wsSource As Worksheet 
Dim wsTarget As Worksheet 


Set wsSource = ThisWorkbook.Worksheets("Tab 1") 
Set wsTarget = ThisWorkbook.Worksheets("Tab 2") 

aCol = 1 
MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row 

For x = 2 To MaxRowList 
    If InStr(1, wsSource.Cells(x, 1), "2016") Then 
    wsTarget.rows(x).Value = wsSource.rows(x).Value 
    End If 
Next 

Application.ScreenUpdating = True 

End Sub 

Любая помощь приветствуется. Заранее спасибо.

Answer 1

Вы можете установить переменную для строки назначения, как это:

Sub CopyRow() 

Application.ScreenUpdating = False 

Dim x As Long 
Dim MaxRowList As Long 
Dim S As String 
Dim wsSource As Worksheet 
Dim wsTarget As Worksheet 


Set wsSource = ThisWorkbook.Worksheets("Tab 1") 
Set wsTarget = ThisWorkbook.Worksheets("Tab 2") 

aCol = 1 
MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row 

destiny_row = 2 
For x = 2 To MaxRowList 
    If InStr(1, wsSource.Cells(x, 1), "2016") Then 
    wsTarget.rows(destiny_row).Value = wsSource.rows(x).Value 
    destiny_row = destiny_row +1 
    End If 
Next 

Application.ScreenUpdating = True 

End Sub 

Таким образом, он начнет копировать эти значения в целевой строке 2 листа и будет увеличиваться в соответствии с если condition.Tell меня, как она идет ...

Answer 2

Sub CopyRow() 

    Application.ScreenUpdating = False 

    Dim x As Long 
    Dim MaxRowList As Long, PrintRow as Long 
    Dim S As String 
    Dim wsSource As Worksheet 
    Dim wsTarget As Worksheet 


    Set wsSource = ThisWorkbook.Worksheets("Tab 1") 
    Set wsTarget = ThisWorkbook.Worksheets("Tab 2") 

    aCol = 1 
    MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row 

    For x = 2 To MaxRowList 
     If InStr(1, wsSource.Cells(x, 1), "2016") Then 
      PrintRow = wsTarget.range("A" & wsTarget.rows.count).end(xlup).row 
      wsTarget.rows(PrintRow).Value = wsSource.rows(x).Value 
     End If 
    Next 

    Application.ScreenUpdating = True 

End Sub 

Answer 3

Вы можете использовать метод AutoFilter, это сэкономит вам нужно использовать цикл For через все строки, а просто скопировать весь отфильтрованный диапазон рабочего листа «Tab 2».

код (объяснение в комментариях)

Option Explicit 

Sub CopyRow() 

Application.ScreenUpdating = False 

Dim x As Long 
Dim MaxRowList As Long 
Dim MaxCol As Long 

Dim S As String 
Dim aCol As Long 
Dim wsSource As Worksheet 
Dim wsTarget As Worksheet 
Dim SourceRng As Range 
Dim VisRng As Range 
Set wsSource = ThisWorkbook.Worksheets("Tab 1") 
Set wsTarget = ThisWorkbook.Worksheets("Tab 2") 

aCol = 1 

With wsSource 
    MaxRowList = .Cells(.Rows.Count, aCol).End(xlUp).Row ' find last row 
    MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column ' find last column 

    Set SourceRng = .Range(.Cells(1, 1), .Cells(MaxRowList, MaxCol)) ' set source range to actually occupied range 

    .Range("A1").AutoFilter ' use AutoFilter method 
    SourceRng.AutoFilter Field:=1, Criteria1:="2016" 

    Set VisRng = SourceRng.SpecialCells(xlCellTypeVisible) ' set range to filterred range 

    VisRng.Copy ' copy entire visible range 
    wsTarget.Range("A2").PasteSpecial xlPasteValues ' past with 1 line 
End With 

Application.ScreenUpdating = True 

End Sub