excel 在具有IF结构的宏中使用用户表单的输出

我正在尝试合并4个模型为一个。所有模型都有一个共同的代码部分以及一个模型特定的部分。我已经创建了一个用户表单，它根据用户选择的条件确定运行什么模型。因此用户表单有4个条件，并产生12个不同的结果。所以我想创建一个子程序，它将运行所有结果代码的公共部分，然后运行特定于结果的部分。
当前用户窗体代码根据选择显示消息框。我想连接此代码（请参阅下文）添加到VBA模型中的代码，并在IF结构中使用。例如，如果用户选择“模板1，私有数据类型”和“第2层，不清除”，则模型将运行公用部分，然后运行具有私有数据类型的模板1的部分，第2层和无擦除，然后再次是一个共同的部分。
例如，擦除/不擦除部分对所有型号来说都是相似的。其他部分有很多相似之处。
以下是用户表单代码：

Private Sub modelrun_btn_Click()

If radiotempl1.Value = True Then
    If datatype.Value = "Public" Then
        If wipe_format.Value = True Then
                MsgBox "Template 1 Public Model Wipe Out"
        Else
                MsgBox "Template 1 Public Model No Wipe Out"
        End If
    ElseIf datatype.Value = "Private" Then
        If radiotier1.Value = True Then
            If wipe_format.Value = True Then
                MsgBox "Template 1 Private Model Tier 1 Wipe Out"
            Else
                MsgBox "Template 1 Private Model Tier 1 No Wipe Out"
            End If
        Else
            If wipe_format.Value = True Then
                MsgBox "Template 1 Private Model Tier 2 Wipe Out"
            Else
                MsgBox "Template 1 Private Model Tier 2 No Wipe Out"
            End If
        End If
    Else
        MsgBox "Please select a data type"
    End If
ElseIf radiotempl2.Value = True Then
    If datatype.Value = "Public" Then
        If wipe_format.Value = True Then
            MsgBox "Template 2 Public Model Wipe Out"
        Else
            MsgBox "Template 2 Public Model No Wipe Out"
        End If
     ElseIf datatype.Value = "Private" Then
        If radiotier1.Value = True Then
            If wipe_format.Value = True Then
                MsgBox "Template 2 Private Model Tier 1 Wipe Out"
            Else
                MsgBox "Template 2 Private Model Tier 1 No Wipe Out"
            End If
        ElseIf radiotier2.Value = True Then
            If wipe_format.Value = True Then
                MsgBox "Template 2 Private Model Tier 2 Wipe Out"
            Else
                MsgBox "Template 2 Private Model Tier 2 No Wipe Out"
            End If
        Else
            MsgBox "Please select a tier"
        End If
    Else
        MsgBox "Please select a data type"
    End If
Else
    MsgBox "Please select a template"
End If

End Sub

这是其中一个模型的例子，基本上它打开一个由不同程序生成的Excel文件，复制一个或两个工作表到模型中（取决于模板），在模型中有一些工作表带有注解掉的公式，所以宏取消注解它们，隐藏那些不需要的，并做一些格式设置。

Sub UploadData()
Dim FileOpenDial As Variant
Dim FileSaveAs As Variant
Dim wb As Workbook
Dim activeWB As Workbook
Dim bFileSaveAs As Boolean
Dim finstart As Range
Dim endcell As Range, startcell As Range
Dim yearsno As Range
Dim numrowsadj As Integer
Dim cfyearsno As Range
Dim numrows As Integer
Dim numrowscf As Integer
Dim c As Range
Dim decimaltab As Range
Dim d As Range
Dim MySheets As Variant
Dim r As Range

'Import the data

'Optimize Code
  
Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

Application.DisplayAlerts = False

Set activeWB = Application.ActiveWorkbook
FileOpenDial = Application.GetOpenFilename(FileFilter:="Excel Files (*.XML), *.XML", Title:="Select File To Be Opened")
If FileOpenDial = False Then Exit Sub
Set wb = Workbooks.Open(FileOpenDial)
    Sheets(Array("Accounts", "Types")).Select
    Sheets(Array("Accounts", "Types")).Copy Before:=activeWB.Sheets(1)
wb.Close savechanges:=False 'or True

'Save a file
FileSaveAs = Application.GetSaveAsFilename(FileFilter:="Exel Files (*.xlsx), *.xlsx", Title:="Select Name To Save The File")
If FileSaveAs <> False Then
            ActiveWorkbook.SaveAs Filename:=FileSaveAs, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If

'Unhide sheets
For Each MySheets In Array("FS", "CF", "tables", "Calcs", "tables_for_output", "Tier_I", "Tier_II")
    Worksheets(MySheets).Visible = True
Next

'Build tables from the data
Sheets("FS").Select

'Remove apostrophe from the formulas
For Each c In Range("D1:D250").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'FillRight Formulas
Set yearsno = ThisWorkbook.Sheets("Accounts").Range("F2:Z2")
numrows = Application.WorksheetFunction.CountA(yearsno)
    If 5 - numrows >= 0 Then
        numrowsadj = 0
    Else: numrowsadj = 5 - numrows
    End If

With ThisWorkbook.Sheets("FS")
    Set startcell = .Range("D1")
    Set endcell = Cells(Range("D" & Rows.Count).End(xlUp).Row, 3 + numrows + numrowsadj)
    Set finstart = .Range(startcell.Address & ":" & endcell.Address)
    finstart.FillRight
End With

ThisWorkbook.Sheets("FS").Range("C1").Select

'Build CF
Sheets("CF").Select

'Remove apostrophe from the formulas
For Each c In Range("F1:F160").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'FillRight Formulas
Set cfyearsno = ThisWorkbook.Sheets("FS").Range("C1:XFD1")
numrowscf = Application.WorksheetFunction.CountA(cfyearsno)

With ThisWorkbook.Sheets("CF")
    Set startcell = .Range("F1")
  
    If numrowscf = 3 Then
        Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 1)
        Set finstart = .Range(startcell.Address & ":" & endcell.Address)
        finstart.FillRight
    ElseIf numrowscf > 3 Then
        Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 2)
        Set finstart = .Range(startcell.Address & ":" & endcell.Address)
        finstart.FillRight
    Else
    End If
End With

ThisWorkbook.Sheets("CF").Range("E1").Select

'Activite the Summary tables
Sheets("tables").Select

For Each c In Range("C1:G88").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

Sheets("tables").Range("B1").Select

'Activate Calcs
Sheets("Calcs").Select
'Remove apostrophe from the formulas
For Each c In Range("B1:H22").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'Activate tables_for_output
Sheets("tables_for_output").Select
For Each c In Range("B2:O43").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'Activate Tier_I
Sheets("Tier_I").Select
For Each c In Range("D6:I15").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'Activate Tier_II
Sheets("Tier_II").Select
For Each c In Range("D6:I15").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'Hide the working worksheets
Sheets(Array("Model", "Calcs")).Visible = False

'Stop Optimize Code
'Call OptimizeCode_End

'ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

'Replace Conditional formating with normal based on a checkbox

If Sheets("Model").Shapes("Check Box 7").ControlFormat.Value = 1 Then

Sheets("tables_for_output").Select

    Range("F4:O4").Select
    
    For Each r In Selection
        r.Interior.Color = r.DisplayFormat.Interior.Color
    Next r
    Selection.FormatConditions.Delete

'Tier_I

Sheets("Tier_I").Select

    Range("F6:H15").Select

    For Each r In Selection
        r.Interior.Color = r.DisplayFormat.Interior.Color
    Next r
    Selection.FormatConditions.Delete

Sheets("Tier_I").Range("C2").Select
    
'Tier_II

Sheets("Tier_II").Select

Range("F6:H15").Select

    For Each r In Selection
        r.Interior.Color = r.DisplayFormat.Interior.Color
    Next r
    Selection.FormatConditions.Delete
End If

ThisWorkbook.Sheets("tables_for_output").Select
    Sheets("tables_for_output").Range("A1").Select
ThisWorkbook.Sheets("Tier_II").Select
    Sheets("Tier_II").Range("C2").Select

'Hide a Tier sheet based on the selection

If Sheets("Calcs").Range("B24").Value = 1 Then
    Sheets("Tier_II").Visible = False
ElseIf Sheets("Calcs").Range("B24").Value = 2 Then
    Sheets("Tier_I").Visible = False
End If

'Formatting
'Columns Width
ThisWorkbook.Sheets("FS").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
ThisWorkbook.Sheets("CF").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit

'Decimal Formatting
'tables
Sheets("tables").Select
Set decimaltab = [C2:E16,C25:E49,C62:E69,C71:E75,C77:E83]

For Each d In decimaltab.SpecialCells(xlCellTypeFormulas, xlNumbers)
    If Abs(d.Value) < 20 And Round(d.Value, 0) <> 0 Then
        d.NumberFormat = "0.0;(0.0)"
    Else
        d.NumberFormat = "#,##0;(#,##0)"
        
   End If
Next d

'tables_for_output
Sheets("tables_for_output").Select
Set decimaltab = [B2:B3,B11:D15,B17:D18,B20:D23,B33:D34,B37:D39,B43:D43]

For Each d In decimaltab.SpecialCells(xlCellTypeFormulas, xlNumbers)
    If Abs(d.Value) < 101 And Round(d.Value, 0) <> 0 Then
        d.NumberFormat = "0.0;(0.0)"
    Else
        d.NumberFormat = "#,##0;(#,##0)"
        
   End If
Next d

Application.ScreenUpdating = True

ActiveWorkbook.Save

End Sub

我就是想不出一个好的方法来把用户表单集成到现有的代码中。我想我需要以变量的形式得到用户表单的输出，然后用它们来构建一个算法。但是我不知道如何开始。
基本上我需要实现以下算法：

Fill User Form
    If any of the options are not selected ask user to do it

Run Upload Data sub
Optimise

    Open external Excel file
        If Template 1 Selected Then
            Import Accounts and Types sheets
        Else
            Import Accounts sheet
        End If
    Save file under a different name
Unhide hiden templates
    If Template 1 Then
        If datatype Private Then
            Unhide FS_1, CF_1, tables, calcs, tables_for_output, Tier 1, Tier 2
            Rename FS_1 and CF_1 to FS and CF
        Else
            Unhide FS_1, CF_1, tables
            Rename FS_1 and CF_1 to FS and CF
    Else
        If datatype Private Then
            Unhide FS_2, CF_2, tables, calcs, tables_for_output, Tier 1, Tier 2
            Rename FS_2 and CF_2 to FS and CF
        Else
            Unhide FS_2, CF_2
            Rename FS_2 and CF_2 to FS and CF
        End If
    End If
Activite Templates
    Activate FS
    Activate CF
    Activate tables
    If datatype Private
        Activate calcs
        Acivate tables_for_output
        Activate Tier 1
        Activate Tier 2
Otimisation ends

Tidying up
    Hide unneeded sheets
        If datatype Private Then
            If Tier 1 Then
                Hide Model, cacls, Tier 2
            Else
                Hide Model, calcs, Tier 1
        Else
            Hide Model
        End If
    If datatype Private replace conditional formatting with normal
        If Tier 1
            In tables_for_otput, Tier 1
        Else
            in tables_for_output, Tier 2
        End If
    
Additional Formattng
    If datatype Public
        Format FS, CF, tables
    Else
        Format FS, CF, table, tables for output
    End If

Workbook Save

Sub End

我上周末已经在做了，但是很早就被打断了。对于延迟，我表示歉意。这里并不真正需要ByVal，我可能用词不正确。如果你想阅读它，这里有一些文档：Byval & ByRef
至于代码，我试着用你提到的方法完成它，但是你的Sub中没有wipe_out，所以也不能实现它。
希望代码工作正常，并且是您指定的方式：

Option Explicit

Sub UploadData()
    Dim FileOpenDial As Variant
    Dim FileSaveAs As Variant
    Dim wb As Workbook, activeWB As Workbook
    Dim bFileSaveAs As Boolean
    Dim finstart As Range, endcell As Range, startcell As Range
    Dim yearsno As Range, cfyearsno As Range
    Dim numrows As Long, numrowscf As Long, numrowsadj As Long 'I prefer to not have number rows in Integer due to limitations of size
    Dim c As Range, d As Range, r As Range, decimaltab As Range
    Dim MySheets As String, tier As String
    Dim templ As Integer, dType As Integer, wipe As Integer
    
    'Checking user form
    If radiotempl1.Value Then templ = 1
    ElseIf radiotempl2.Value Then templ = 2
    Else
        MsgBox "Please select a template"
    End If
    
    If dataType.Value = "Public" Then
        dType = 1
    ElseIf dataType.Value = "Private" Then
        dType = 2
    Else
        MsgBox "Please select a data type"
    End If
    
    If wipe_format.Value Then wipe = 1
    
    If radiotier1.Value Then tier = "Tier_1"
    If radiotier2.Value Then tier = "Tier_2"
    Else
        If dType = 2 Then
            MsgBox "Please select a tier"
            Exit Sub
        End If
    End If
    
    If templ + dType < 2 Then Exit Sub
    
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayAlerts = False
    
    Set activeWB = Application.ActiveWorkbook
    FileOpenDial = Application.GetOpenFilename(FileFilter:="Excel Files (*.XML), *.XML", Title:="Select File To Be Opened")
    If FileOpenDial = False Then Exit Sub
    Set wb = Workbooks.Open(FileOpenDial)
    'you mentioned "copies one or two worksheets into the model (depending on the template) but I'm not sure which way you wanted this
    Sheets(Array("Accounts", "Types")).Copy Before:=activeWB.Sheets(1) 'avoid select as much as possible
    wb.Close savechanges:=False 'or True
    
    'Save a file
    FileSaveAs = Application.GetSaveAsFilename(FileFilter:="Exel Files (*.xlsx), *.xlsx", Title:="Select Name To Save The File")
    If FileSaveAs <> False Then
                ActiveWorkbook.SaveAs Filename:=FileSaveAs, _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End If
    
    copySheet "FS", templ 'this is to copy the right sheet and delete the FS if it alreasdy existed from a previous time you ran the code
    copySheet "CF", templ
    
    
    Set yearsno = ThisWorkbook.Sheets("Accounts").Range("F2:Z2")
    
    With Sheets("FS")
        'Remove apostrophe from the formulas
        For Each c In .Range("D1:D250").SpecialCells(xlCellTypeConstants)
            c.Formula = Replace(c.Formula, "'", "")
        Next c
        
        numrows = Application.WorksheetFunction.CountA(yearsno)
        If 5 - numrows >= 0 Then
            numrowsadj = 0
        Else: numrowsadj = 5 - numrows
        End If
    
        Set startcell = .Range("D1")
        Set endcell = Cells(Range("D" & Rows.Count).End(xlUp).Row, 3 + numrows + numrowsadj)
        Set finstart = .Range(startcell.Address & ":" & endcell.Address)
        finstart.FillRight
        Set cfyearsno = .Range("C1:XFD1")
        numrowscf = Application.WorksheetFunction.CountA(cfyearsno)
    End With
        
    With Sheets("CF")
        'Remove apostrophe from the formulas
        For Each c In Range("F1:F160").SpecialCells(xlCellTypeConstants)
            c.Formula = Replace(c.Formula, "'", "")
        Next c
        Set startcell = .Range("F1")
  
        If numrowscf = 3 Then
            Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 1)
            Set finstart = .Range(startcell.Address & ":" & endcell.Address)
            finstart.FillRight
        ElseIf numrowscf > 3 Then
            Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 2)
            Set finstart = .Range(startcell.Address & ":" & endcell.Address)
            finstart.FillRight
        Else
        End If
    End With
    
    With Sheets("tables")
        For Each c In .Range("C1:G88").SpecialCells(xlCellTypeConstants)
            c.Formula = Replace(c.Formula, "'", "")
        Next c
    End With
    
    With Sheets("Calcs")
        For Each c In Range("B1:H22").SpecialCells(xlCellTypeConstants)
            c.Formula = Replace(c.Formula, "'", "")
        Next c
    End With
    
    With Sheets("tables_for_output")
        For Each c In Range("B2:O43").SpecialCells(xlCellTypeConstants)
            c.Formula = Replace(c.Formula, "'", "")
        Next c
    End With
        
    'no need to hide sheets if you keep them hidden :)
    
    Calculate
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    With Sheets("tables_for_output")
        For Each r In Range("F4:O4")
            r.Interior.Color = r.DisplayFormat.Interior.Color
        Next r
        Range("F4:O4").FormatConditions.Delete
    End With
    
    If dType = 2 Then
        With Sheets(tier) 'same here as last time with tier
            For Each c In .Range("D6:I15").SpecialCells(xlCellTypeConstants)
                c.Formula = Replace(c.Formula, "'", "")
            Next c
            For Each r In Range("F6:H15")
                r.Interior.Color = r.DisplayFormat.Interior.Color
            Next r
            Range("F6:H15").FormatConditions.Delete
            .Visible = True
        End With
    End With
    
    'Formatting
    'Columns Width
    ThisWorkbook.Sheets("FS").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
    ThisWorkbook.Sheets("CF").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
    
    'Decimal Formatting
    'tables
    With Sheets("tables")
    Set decimaltab = Union(.Range("C2:E16"), .Range("C25:E49"), .Range("C62:E69"), .Range("C71:E75"), .Range("C77:E83"))
    
    For Each d In decimaltab.SpecialCells(xlCellTypeFormulas, xlNumbers)
        If Abs(d.Value) < 20 And Round(d.Value, 0) <> 0 Then
            d.NumberFormat = "0.0;(0.0)"
        Else
            d.NumberFormat = "#,##0;(#,##0)"
            
       End If
    Next d
    
    'tables_for_output
    With Sheets("tables_for_output")
        Set decimaltab = Union(.Range("B2:B3"), .Range("B11:D15"), .Range("B17:D18"), .Range("B20:D23"), .Range("B33:D34"), .Range("B37:D39"), .Range("B43:D43"))
        
        For Each d In decimaltab.SpecialCells(xlCellTypeFormulas, xlNumbers)
            If Abs(d.Value) < 101 And Round(d.Value, 0) <> 0 Then
                d.NumberFormat = "0.0;(0.0)"
            Else
                d.NumberFormat = "#,##0;(#,##0)"
                
           End If
        Next d
        .Activate
    'You will have to decide which sheet you actually want to be presented first but I got rid of the copious use of .Select
    'For now it's this one
    End With
    
    Application.ScreenUpdating = True
    
    ActiveWorkbook.Save
End Sub

Sub copySheet(shtName As String, templNo As Integer)
    If WorksheetExists(shtName) Then ActiveWorkbook.Sheets(shtName).Delete
    shtName = shtName & "_" & templNo
    Sheets(shtName).Copy After:=Worksheets(Worksheets.Count)
    With ActiveSheet
        .Name = Left(shtName, 2)
        .Visible = True
    End With
End Sub

Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ActiveWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

如果你还有什么问题，尽管问

excel 在具有IF结构的宏中使用用户表单的输出

1条答案

相关问题

热门标签

最新问答