VBA WITH-END 结合 IF-ELSE

Question

不确定我的标题是否正确描述了我正在尝试做的事情，但这里是：

我有一个宏，它可以打开一个 .csv 文件并查找标题。像这样：

With Application.WorksheetFunction
    ValArray(1) = .Match(ptOne, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(2) = .Match(ptTwo, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(3) = .Match(ptThree, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(4) = .Match(ptFour, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(5) = .Match(ptFive, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(6) = .Match(ptSix, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(7) = .Match(ptSeven, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(8) = .Match(ptEight, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
End With

用户在保存宏按钮的电子表格中定义标题名称，该按钮分配给变量 ptOne、ptTwo 等。在宏电子表格中，使用上面的代码，用户可以定义 8 个变量标题，但我希望他们能够在宏工作表中分配 7 个或 10 个变量。

我在其他地方使用 counta 来计算用户在电子表格中分配的标题数量。我想使用 IF 语句之类的东西来查找用户定义的尽可能多或尽可能少的标题。

有什么想法吗？我在描述这一点时遇到了一些麻烦，但请询问我是否感到困惑。提前感谢您的任何建议。

要筛选的有点多，但这里是完整的代码：

Sub gasCollectionSystem()

Dim RawWbName As String
Dim RawWb As Workbook
Dim RawWs As Worksheet
Dim NewWb As Workbook
Dim NewWs As Worksheet
Dim ValArray(1 To 25) As Long
Dim Cel As Range
Dim r As Range
Dim DateTime As Date
Dim SearchRange As Range
Dim FindRow As Range
Dim monitorRange As Range
Dim numMonitorPts As Integer
'Dim ptOne As Range
'Dim ptTwo As Range
'Dim ptThree As Range
'Dim ptFour As Range
'Dim ptFive As Range
'Dim ptSix As Range
'Dim ptSeven As Range
'Dim ptEight As Range

RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")

Set ptOne = Range("H4")
Set ptTwo = Range("I4")
Set ptThree = Range("J4")
Set ptFour = Range("K4")
Set ptFive = Range("L4")
Set ptSix = Range("M4")
Set ptSeven = Range("N4")
Set ptEight = Range("O4")

Set lblOne = Range("H5")
Set lblTwo = Range("I5")
Set lblThree = Range("J5")
Set lblFour = Range("K5")
Set lblFive = Range("L5")
Set lblSix = Range("M5")
Set lblSeven = Range("N5")
Set lblEight = Range("O5")

Set frmtOne = Range("H6")
Set frmtTwo = Range("I6")
Set frmtThree = Range("J6")
Set frmtFour = Range("K6")
Set frmtFive = Range("L6")
Set frmtSix = Range("M6")
Set frmtSeven = Range("N6")
Set frmtEight = Range("O6")

Set monitorRange = Range("H4:W4")
numMonitorPts = Application.WorksheetFunction.CountA(monitorRange)
MsgBox (numMonitorPts)

Workbooks.Open RawWbName, local:=True
Set RawWb = ActiveWorkbook
Set RawWs = ActiveSheet
Set NewWb = Workbooks.Add
Set NewWs = ActiveSheet
RawWb.Activate




With RawWb.Sheets(RawWs.Name)
Set SearchRange = .Range("A1", Range("A65536").End(xlUp))
Set FindRow = SearchRange.Find("ID", LookIn:=xlValues, lookat:=xlWhole)
End With
NewWb.Sheets(NewWs.Name).Cells(1, 1) = RawWs.Cells(1, 1)

'RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")



With Application.WorksheetFunction
    ValArray(1) = .Match(ptOne, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(2) = .Match(ptTwo, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(3) = .Match(ptThree, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(4) = .Match(ptFour, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(5) = .Match(ptFive, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(6) = .Match(ptSix, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(7) = .Match(ptSeven, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
    ValArray(8) = .Match(ptEight, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
End With

'do ID
RawWs.Range(("a" & FindRow.Row) & ":a65536").Copy
NewWs.Activate
NewWs.Range("a1").Select
NewWs.Paste
Range("a1").Select
ActiveCell.FormulaR1C1 = "01 Asset ID"

'do DateTime
RawWs.Range(("b" & FindRow.Row) & ":b65536").Copy
NewWs.Range("b1").Select
NewWs.Paste
Columns("B:B").Select
Selection.NumberFormat = "dd-mm-yyyy h:mm"
Range("b1").Select
ActiveCell.FormulaR1C1 = "02 Date/Time"

'do Value1
RawWb.Activate
Range(RawWs.Cells(FindRow.Row + 1, ValArray(1)), RawWs.Cells(65536, ValArray(1))).Select
Selection.Copy
NewWb.Activate
NewWs.Range("c2").Select
NewWs.Paste
Columns("C:C").Select
Selection.NumberFormat = frmtOne
Range("c1").Select
ActiveCell.FormulaR1C1 = "03 " & lblOne

'do Value2

Range(RawWs.Cells(FindRow.Row + 1, ValArray(2)), RawWs.Cells(65536, ValArray(2))).Copy
NewWs.Range("d2").Select
NewWs.Paste
Columns("d:d").Select
Selection.NumberFormat = frmtTwo
Range("d1").Select
ActiveCell.FormulaR1C1 = "04 " & lblTwo

'do Value3
Range(RawWs.Cells(FindRow.Row + 1, ValArray(3)), RawWs.Cells(65536, ValArray(3))).Copy
NewWs.Range("e2").Select
NewWs.Paste
Columns("e:e").Select
Selection.NumberFormat = frmtThree
Range("e1").Select
ActiveCell.FormulaR1C1 = "05 " & lblThree

'do Value4
Range(RawWs.Cells(FindRow.Row + 1, ValArray(4)), RawWs.Cells(65536, ValArray(4))).Copy
NewWs.Range("f2").Select
NewWs.Paste
Set r = Intersect(NewWs.Range("f3:f65536"), NewWs.UsedRange)
If Not r Is Nothing Then
    For Each Cel In r.Cells
        If Cel < 0 Then
            Cel.Value = 0
        End If
    Next Cel
    End If
Columns("f:f").Select
Selection.NumberFormat = frmtFour
Range("f1").Select
ActiveCell.FormulaR1C1 = "06 " & lblFour

'do Value5
Range(RawWs.Cells(FindRow.Row + 1, ValArray(5)), RawWs.Cells(65536, ValArray(5))).Copy
NewWs.Range("g2").Select
NewWs.Paste
Columns("g:g").Select
Selection.NumberFormat = frmtFive
Range("g1").Select
ActiveCell.FormulaR1C1 = "07 " & lblFive

'do Value6
Range(RawWs.Cells(FindRow.Row + 1, ValArray(6)), RawWs.Cells(65536, ValArray(6))).Copy
NewWs.Range("h2").Select
NewWs.Paste
Columns("h:h").Select
Selection.NumberFormat = frmtSix
Range("h1").Select
ActiveCell.FormulaR1C1 = "08 " & lblSix

'do Value7
Range(RawWs.Cells(FindRow.Row + 1, ValArray(7)), RawWs.Cells(65536, ValArray(7))).Copy
NewWs.Range("i2").Select
NewWs.Paste
Columns("i:i").Select
Selection.NumberFormat = frmtSeven
Range("i1").Select
ActiveCell.FormulaR1C1 = "09 " & lblSeven

'do Value8
Range(RawWs.Cells(FindRow.Row + 1, ValArray(8)), RawWs.Cells(65536, ValArray(8))).Copy
NewWs.Range("j2").Select
NewWs.Paste
Columns("j:j").Select
Selection.NumberFormat = frmtEight
Range("j1").Select
ActiveCell.FormulaR1C1 = "10 " & lblEight


Rows("2:2").Select
Selection.Delete Shift:=xlUp

NewWb.SaveAs Filename:=RawWb.Path & "\Landfill_Gs Ext " & RawWb.Name, FileFormat:=xlCSV
' NewWb.Close


RawWb.Close

End Sub

谢谢！

Answer 1

已编译但未经测试 - 这可能会给您一些想法。

Sub gasCollectionSystem()

Dim RawWbName As String
Dim RawWb As Workbook
Dim RawWs As Worksheet
Dim NewWb As Workbook
Dim NewWs As Worksheet

Dim Cel As Range
Dim r As Range
Dim DateTime As Date
Dim SearchRange As Range
Dim FindRow As Range
Dim monitorRange As Range
Dim numMonitorPts As Integer

Const MAX_BLANK As Long = 10
Dim ptOne As Range
Dim colName As String, colLabel As String, colFormat As String
Dim numBlank As Long, f As Range, pasteCol As Long
Dim rngCopy As Range

    RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")

    Set RawWb = Workbooks.Open(RawWbName, local:=True)
    Set RawWs = RawWb.Sheets(1)

    Set SearchRange = RawWs.Range("A1", Range("A65536").End(xlUp))
    Set FindRow = SearchRange.Find("ID", LookIn:=xlValues, lookat:=xlWhole)

    'check we found the "ID" row...
    If FindRow Is Nothing Then
        MsgBox "Value 'ID' not found in ColA", vbCritical
        Exit Sub
    Else
        Set FindRow = FindRow.EntireRow
    End If

    'set up new workbook
    Set NewWb = Workbooks.Add()
    Set NewWs = NewWb.Sheets(1)
    NewWb.Sheets(NewWs.Name).Cells(1, 1) = RawWs.Cells(1, 1)

    'copy first two columns
    DoCopy RawWs.Range(("A" & FindRow.Row) & ":A65536"), _
           NewWs.Range("A1"), "01 Asset ID", ""

    DoCopy RawWs.Range(("B" & FindRow.Row) & ":B65536"), _
           NewWs.Range("B1"), "02 Date/Time", "dd-mm-yyyy h:mm"

    'add your actual sheet name in the next line...
    Set ptOne = ThisWorkbook.Sheets("Setup").Range("H4")
    numBlank = 0
    pasteCol = 3

    Do While numBlank < MAX_BLANK

        colName = Trim(ptOne.Value)
        colLabel = Trim(ptOne.Offset(1, 0).Value)
        colFormat = Trim(ptOne.Offset(2, 0).Value)

        If Len(colName) > 0 Then

            Set f = FindRow.Find(colName, , xlValues, xlWhole)
            If Not f Is Nothing Then

                Set rngCopy = f.Parent.Range(f, _
                              f.Parent.Cells(Rows.Count, f.Column).End(xlUp))

                'copy the data
                DoCopy rngCopy, NewWs.Cells(1, pasteCol), _
                       pasteCol & " " & colLabel, colFormat

                pasteCol = pasteCol + 1 'new column over for pasting

            End If

            numBlank = 0
        Else
            numBlank = numBlank + 1
        End If

        Set ptOne = ptOne.Offset(0, 1) 'next config column

    Loop

    NewWb.SaveAs Filename:=RawWb.Path & "\Landfill_Gs Ext " & RawWb.Name, FileFormat:=xlCSV
    ' NewWb.Close


    RawWb.Close


End Sub

'generic copy/format sub
'doesn't handle your "value4" special formatting though
Sub DoCopy(rngSrc As Range, rngPaste As Range, colLabel As String, fmt As String)

    rngSrc.Copy rngPaste
    rngPaste.Value = colLabel
    If Len(fmt) > 0 Then
        Application.Intersect(rngPaste.EntireColumn, _
              rngPaste.Parent.UsedRange).NumberFormat = fmt
    End If

End Sub