Question

我有一个已嵌入VBA代码的文件。该模板文件基本上基于主键标识符创建新文件。我有一个主数据文件，模板使用该文件来查找要填充的特定值，然后模板根据主键填充数据。然后，VBA代码将这些值复制并粘贴到新工作表中，然后看起来像使用主文件中的数据填充所有字段的模板。

我目前必须输入每个主键并重新运行VBA代码，为每个主键创建一个新文件。

我有主键列表，我想用现有代码来代替，这些代码将重复列表中每个主键的功能，而无需手动输入每个主键。

以下是代码：

Sub Macro1()
    Dim TheFileName As String
    Dim TheResponse As Integer
    Dim Modelworkbook As String

    TheFileName = Range("C_filename").Value

    '=======================================
    ' Copy data into new worksheet
    '=======================================

    Cells.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A21:I91").Select
    Application.CutCopyMode = False

    '=======================================
    ' Setup new print area and page setup
    '=======================================

    ActiveSheet.PageSetup.PrintArea = "$A$21:$I$91"
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.25)
        .FooterMargin = Application.InchesToPoints(0.25)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    Range("B48").Select

    '=======================================
    ' Prepare to save new worksheet export
    '=======================================

    '===============================
    ' CHECK THAT WANT TO EXPORT
    '===============================

    TheResponse = MsgBox("Are you sure you want to export the results to " + TheFileName + "? ", vbYesNo + vbCritical + vbDefaultButton2, "Do you want to continue")

    If TheResponse = vbNo Then
        MsgBox "Export Terminated"
        Application.Goto Reference:="i_name"
        Exit Sub
    End If

    '=======================================
    ' Verify that file is not already there
    '=======================================

    If Dir(TheFileName) <> "" Then

        TheResponse = MsgBox(TheFileName + " Already Exists? OVERWRITE? ", vbYesNo + vbCritical + vbDefaultButton2, "Do you want to continue")

        If TheResponse = vbNo Then
            MsgBox "Export Terminated"
            Application.Goto Reference:="i_name"
            Exit Sub
        End If
    End If

    '=======================================
    ' Save the file
    '=======================================

    Application.DisplayAlerts = False

    ActiveWorkbook.SaveAs Filename:=TheFileName, _
        FileFormat:=51, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    Application.DisplayAlerts = True

    '==============================================
    ' Copy certain formulas from template to export
    '==============================================

    Modelworkbook = ActiveWorkbook.Name

    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Range("B53").Select
    Application.Goto Reference:="ValuationAnalysis"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("B53").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Range("f89").Select
    Application.Goto Reference:="preppedby"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("f89").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Range("h37").Select
    Application.Goto Reference:="aigparticipation"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("h37").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Range("m4").Select
    Application.Goto Reference:="concluded"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("m4").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("B23").Select
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Range("B51").Select
    Windows(Modelworkbook).Activate
    Range("B23").Select
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Application.Goto Reference:="OperPerform"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("G42").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Application.Goto Reference:="LoanTermsCalcs"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("E32").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Application.Goto Reference:="InvestmentMgr"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Application.Goto Reference:="PreparedBy"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("F4").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Windows( _
        "1-Loan Status Update Template.xlsm" _
        ).Activate
    Application.Goto Reference:="Recommend"
    Selection.Copy
    Windows(Modelworkbook).Activate
    Range("C10").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False





    '=======================================
    ' ReSave the file
    '=======================================

    Application.DisplayAlerts = False

    ActiveWorkbook.SaveAs Filename:=TheFileName, _
        FileFormat:=51, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    Application.DisplayAlerts = True

    '=======================================
    ' Close Exported file
    '=======================================

    ActiveWorkbook.Close

End Sub

Answer 1

对一组单元格使用Range对象。获取单元格的值，然后在调用例程之前对其进行验证。

此示例假设您正在使用整列，并将停在第一个空白单元格，仅使用Long值：

Public Sub RunForColumnB()

    Dim oColumn As Range
    Dim oCell As Range
    Dim sVal As String

    'this looks in column B on Sheet1
    Set oColumn = Worksheets("Sheet1").Range("B:B")

    For Each oCell In oColumn
        sVal = oCell.Value
        If sVal = "" Then
            Exit Sub
        ElseIf IsNumeric(sVal) Then

            'your code goes here
            Debug.Print CLng(sVal)

        End If
    Next 'oCell

End Sub

如何在值列表上重复执行函数？

1 个答案: