需要帮助缩短我的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