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

需要帮助缩短我的VBA代码并使其循环

2 个答案: