Help me with the VBA Code

[thedeadzeds]

Hi Guys,

I have the following code which works great. It essentially finds the column name from the data tab and copies the data to the New Tab. Is there a way to create a message if for some reason the column names are not found in the data tab? So if any of the column headers are not found, end the code with a message. FYI, this is just a snippet of the code, at some point i will need to create for about 15 column headers.

Many thanks

Sub New()

If MsgBox("Are you sure you want to run VBA?", vbYesNo) = vbNo Then Exit Sub

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data") '<== Sheet that has raw data
Dim LRow As Long, Found As Range
Dim lastRow As String
Dim lastRow2 As String
lastRow = Sheets("New").Cells(Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("New").Cells(Rows.Count, "B").End(xlUp).Row


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' Dealership
Set Found = ws.Range("A1:KG1").Find("Dealership") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(2, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("New").Range("A" & lastRow + 1).PasteSpecial xlPasteValues '<== Sheet to paste data
End If

ws.Activate
ActiveSheet.Select

' Date
Set Found = ws.Range("A1:KG1").Find("OrderDate") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(2, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("New").Range("B" & lastRow + 1).PasteSpecial xlPasteValues '<== Sheet to paste data
End If

ws.Activate
ActiveSheet.Select



End Sub

 

[Joe4]

You could change this:

Set Found = ws.Range("A1:KG1").Find("Dealership") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(2, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("New").Range("A" & lastRow + 1).PasteSpecial xlPasteValues '<== Sheet to paste data
End If

to something like this:

Set Found = ws.Range("A1:KG1").Find("Dealership") '<== Header name to search for
If Found Is Nothing Then
    MsgBox "Cannot find Dealership", vbOkOnly, "ERROR!"
    Exit Sub
Else
    LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
    ws.Range(ws.Cells(2, Found.Column), ws.Cells(LRow, Found.Column)).Copy
    Sheets("New").Range("A" & lastRow + 1).PasteSpecial xlPasteValues '<== Sheet to paste data
End If

 

[thedeadzeds]

That works thanks for your help but i was wondering if there was a way to check the column header names before the other code is run. So check if the coulmn header names exisit, if they do run the code, if they do not message saying which ones are not found.

 

[Joe4]

You can use an array to store all the headers that you want to look for, and loop through them to see if they exist at the beginning of your code.
That would look something like this:

Dim Found
Dim hdrs()
Dim i As Long
Dim missing As String
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data") '<== Sheet that has raw data

'Store array of headers to look for
hdrs = Array("Dealership", "OrderDate")

'Loop through array of headers to look for in row 1
For i = LBound(hdrs) To UBound(hdrs)
    Set Found = ws.Range("A1:KG1").Find(hdrs(i)) '<== Header name to search for
'   If header is not found, add it to the "missing" list
    If Found Is Nothing Then
        missing = missing & hdrs(i) & ", "
    End If
Next i

'Check to see if there are any missing headers
If Len(missing) > 0 Then
    MsgBox "Missing headers " & Left(missing, Len(missing) - 2), vbOKOnly, "MACRO CANCELLED!"
    Exit Sub
End If

You would just update your "hdrs" array and add the other headers that you want to look for.

 

[thedeadzeds]

That is perfect thanks very much

 

[Joe4]

You are welcome.