在Excel中將空行復制到使用VBA的新工作表中後刪除空行

Question

我已成功編寫了一個Excel VBA腳本，用於檢查列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循環，只是整個過濾範圍複製到「選項卡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