循环代码以多次运行宏

Question

我有这个 vba 宏，它从文本文件中提取数据并将其放入 Excel 中的列中。这些文件以天数 (2016mmdd) 命名。目前，我每天都运行这个宏。现在我希望它在运行此宏时，声明月份（例如八月）中所有天的数据将自动提取到不同的列中（每个月的每一天一列）。这样如果一个月有 31 天，我就不必手动运行 31 次。感谢您的帮助。

Sub Macro7()
'
' Macro7 Macro
'
' Keyboard Shortcut: Ctrl+x
'

Dim fileDate, rng, rng1, rng2, rng3, rcell As String

 b = InputBox("Enter file Name mmdd", "File name")
 rcell = InputBox("Enter cell reference", "Reference name")

 rng = "$" & rcell & "$2"
 rng1 = rcell & "2:" & rcell & "14"
 rng2 = rcell & "52:" & rcell & "62"
 rng3 = rcell & "2:" & rcell & "101"

 Filename = "j:\files\2016" & b & "2259.txt"

     With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;j:\files2016" & b & "2259.txt", Destination:= _
        Range(rng))

        .Name = "tr" & b
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 1, 9)
        .TextFileFixedColumnWidths = Array(103, 4)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

    Range(rng1).Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=45
    Range(rng2).Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=-60
    Range(rng3).Select
End Sub

Answer 1

快速的方法是重写 Sub Macro7() 以接受参数，例如

Sub ImportFiles(FName As String, ColNum As Integer)

    ' blablabla

    ' work with range objects ... not with patched strings containing range addresses
    Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range

    Set Rng = Cells(2, ColNum)
    Set Rng1 = Range(Cells(2, ColNum), Cells(14, ColNum))
    Set Rng2 = Range(Cells(52, ColNum), Cells(62, ColNum))
    Set Rng3 = Range(Cells(2, ColNum), Cells(101, ColNum))

    Filename = "j:\files\2016" & FName & "2259.txt"

    ' and replace <Destination := Range(Rng)> by <Destination := Rng>

    ' blablabla

    ' use the range objects defined/set earlier ... save on Select/Selection
    Rng1.Delete xlUp
    Rng2.Delete xlUp
    Rng3.Select


End Sub

并有一个调用宏，例如

Sub DoWorklist()

    ImportFiles "0901", 1
    ImportFiles "0902", 2
    ImportFiles "0903", 3
    ' blablabla

    'alternative

    Dim Idx As Integer

    For Idx = 1 To 30
         ' to overcome well spotted chr() issue we convert running number Idx
         ' into 2 digit string with leading "0"
        ImportFiles "09" & Format(Idx, "00"), Idx
    Next Idx


End Sub