需要幫助縮短我的VBA代碼，並使其循環

Question

所以我有一些數據，我需要每月運行我的宏。我的代碼適用於我所需要的內容，但我認爲這對我來說可能是一個很好的機會嘗試和學習如何循環一些重複性很強的東西，因爲我對這些仍然很陌生。所以下面是我的代碼，基本上它只是複製列A和另一個指定列中的所有內容，將它們粘貼到一個新工作表中，重命名Sheet1上某個單元格後的工作表，並刪除包含空白單元格的所有空行。我只是簡單地複製並粘貼原始錄製的宏，並做了一些更改，使其完成整個工作表。

我會試着學習如何將它縮小和循環，而不是複製和粘貼它。這對我來說更像是一個學習的東西，因爲這個宏已經適用於我所需要的東西。

非常感謝！

Sub test() 
' 
'  test Macro 
' 

' 
    Application.ScreenUpdating = False 

Range("A:A,B:B").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("B1").Value 
Sheets("Sheet1").Activate 



Range("A:A,C:C").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("C1").Value 
Sheets("Sheet1").Activate 



Range("A:A,D:D").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("D1").Value 
Sheets("Sheet1").Activate 



Range("A:A,E:E").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("E1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,F:F").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("F1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,G:G").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("G1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,H:H").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("H1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,I:I").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("I1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,J:J").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("J1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,K:K").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("K1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,L:L").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("L1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,M:M").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("M1").Value 
Sheets("Sheet1").Activate 



    Range("A:A,N:N").Select 
Selection.Copy 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Paste 
    On Error Resume Next 
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
ActiveSheet.UsedRange 
ActiveSheet.Name = Sheet1.Range("N1").Value 
Sheets("Sheet1").Activate 






End Sub 

Answer 1

我會做這樣的事情：

Sub test() 

Dim CurrentColumn As String 'define a variable 

For i = 1 To 13 'loop over the letter B to N (13 values if I counted right) 
    CurrentColumn = Chr(65 + i) 'Here you play with ascii table 65 is the code for A, 66 for B, etc. 

    Range("A:A," & CurrentColumn & ":" & CurrentColumn).Select 'replace in the string the fix value by our variable 
    Selection.Copy 
    Sheets.Add After:=Sheets(Sheets.Count) 
    ActiveSheet.Paste 
    On Error Resume Next 
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
    ActiveSheet.UsedRange 
    ActiveSheet.Name = Sheets("Sheet1").Range(CurrentColumn & "1").Value 'same here 
    Sheets("Sheet1").Activate 
Next 

End Sub 

的ascii table

爲例告訴我，如果你需要比什麼是在評論

Answer 2

我想使它成爲一個更加細節子程序... 試試這個：

Sub test() 

Dim SecondColumnIndexNumber As Integer 

Application.ScreenUpdating = False 

    For SecondColumnIndexNumber = 2 To 13 
     DoTheMove (SecondColumnIndexNumber) 
    Next 

Application.ScreenUpdating = True 

End Sub 

---

Sub DoTheMove(SecondColumnIndexNumber As Integer) 
' This takes a number as the input for the second column that will be copied over 
' For example 2 corresponds to copying over columns A (always the case) and column B - Range("A:A,B:B") 
' For example 4 corresponds to copying over columns A (always the case) and column D - Range("A:A,D:D") 

Dim NewSheet As Worksheet 
Dim SecondColumn As Range 
Dim RangeToCopy As Range 

Set NewSheet = Sheets.Add(After:=Sheets(Sheets.Count)) 
Set SecondColumn = Sheets("Sheet1").Columns(SecondColumnIndexNumber) 
Set RangeToCopy = Union(Sheets("Sheet1").Range("A:A"), SecondColumn) 

    NewSheet.Activate 
    RangeToCopy.Copy NewSheet.Range("A1") 
    On Error Resume Next 
    NewSheet.Range("A:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
    NewSheet.Name = Sheet1.Cells(1, SecondColumn).Value 
End Sub