VBA WITH-END combined with IF-ELSE - vba

Question

Not sure if my title properly describes what I am try to do, but here goes:
I have a macro which opens a .csv file and looks for headers. Like this:
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
The user defines the header name in the spreadsheet where the macro button is kept which is assigned to the variable ptOne, ptTwo and so on. In the macro spreadsheet, using the above code, the user can define 8 variables headers, but I'd like them to be able to assign 7 or 10 variables in the macro worksheet.
I'm using counta elsewhere to count the number of headers the user assigns in the spreadsheet. I'd like to use something like an IF Statement to find as many or as few headers as the user defines.
Any ideas? I'm having a bit of trouble describing this, but please ask if I'm confusing. Thanks in advance for any suggestions.
Its a little much to sift through, but here is the full code:
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
Thanks!

Answer 1

Compiled but not tested - this might give you some ideas.
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