VBA code to format table, insert 3 columns right, do a vlookup and split table in separate workbooks
Hey all!
I have a table which contains data from xml files.
This table has 12 columns.
I'm trying to create a vba code which will do the following:
1. delete the first column table.
2. delete blank rows.
3. add a column next to column 3 in order to format data from column 3 as =TEXT([@column3],"000000000").
4. delete column 3.
5. Rename (new) column 3 as "ApplicantVatNumber".
6. Insert 3 columns right named as "Skroutz", "Mickey", 'Mini".
7. do a vlookup in all 3 new columns using as key the column 3 and table array from respective sheets in other workbook.
8. Split table in multiple workbooks based on the value in column A. New workbooks have to be named as "Walt_Disney_X.xlsx" where X is the value in column A. These workbooks have to be stored in folders that i will define.
9. Keep the original sheet.
This my code but, aparently, doesn't work:
Sub FormatTable()
'Delete the first column
Columns(1).Delete
'Delete blank rows
Rows.SpecialCells(xlCellTypeBlanks).Delete
'Add column next to column C
Columns(3).Insert
'Format data in new column
Range("D2").Formula = "=TEXT([@column3],""000000000"")"
'Delete column C
Columns(3).Delete
'Rename column D as "ApplicantVatNumber"
Columns(3).Name = "ApplicantVatNumber"
'Insert 3 columns to the right
Columns(4).Insert
Columns(5).Insert
Columns(6).Insert
'Name new columns
Columns(4).Name = "Skroutz"
Columns(5).Name = "Mickey"
Columns(6).Name = "Mini"
'Do vlookup using column C as key
Range("Skroutz2:Skroutz" & Cells(Rows.Count, "C").End(xlUp).Row).Formula = "=iferror(VLOOKUP(C2,'path to xlsx'sheet,2,FALSE),'0'"
Range("Mickey2:Mickey" & Cells(Rows.Count, "C").End(xlUp).Row).Formula = "=iferror(VLOOKUP(C2,'path to xlsx'sheet,2,FALSE),'0'"
Range("Mini2:mini" & Cells(Rows.Count, "C").End(xlUp).Row).Formula = "=iferror(VLOOKUP(C2,'path to xlsx'sheet,2,FALSE),'0'"
'Split table into multiple workbooks
Dim ws As Worksheet
Dim var As Variant
Set ws = ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
var = ws.Range("A2:F" & lastRow)
Dim i As Integer
For i = 2 To lastRow
If Not IsEmpty(Cells(i, 1)) Then
var(i - 1, 1) = Cells(i, 1).Value
If Not Dir("Walt_Disney_" & Cells(i, 1).Value & ".xlsx") = "" Then
Set newWB = Workbooks.Add
Set newWS = newWB.Sheets(1)
ws.Range("A" & i & ":F" & i).Copy Destination:=newWS.Range("A1")
newWB.SaveAs "Walt_Disney_" & Cells(i, 1).Value & ".xlsx"
newWB.Close
Else
Set newWB = Workbooks.Open("Walt_Disney_" & Cells(i, 1).Value & ".xlsx")
Set newWS = newWB.Sheets(1)
ws.Range("A" & i & ":F" & i).Copy Destination:=newWS.Cells(newWS.Rows.Count, 1).End(xlUp).Offset(1, 0)
newWB.Save
newWB.Close
End If
End If
Next i
End Sub
Any help will be valuable!
Thanks in advance!
|