Copy and Save in specific way

[K]

A B C D E….col
Chrg App Total Amt Name…..headings
LA1 F01 7780 2190 DAVID
LA1 F21 7781 2191 DAVID
LA1 G61 7782 2192 DAVID
D35 G83 7783 2193 JOHN
D35 G87 7784 2194 JOHN
D35 G87 7785 2195 JOHN
D31 G87 7786 2196 ALI
D31 LC1 7787 2197 ALI
D31 LE1 7788 2198 ALI
G68 G68 7789 2199 STEVE
G68 G70 7790 2200 STEVE
G68 NA1 7791 2201 ROB
G68 PA1 7792 2202 ROB


I have three sheets in workbook with the names "MAIN" , "DATA" and
"TEMPLATE". In sheet "DATA" I have above data. In column A of sheet
"MAIN" I have data (see below)

A….col
Chrg….heading
LA1
D31
MC3
G68
F23

I want macro something like (see below)

1 - check column A values of sheet "MAIN" in column A of sheet "DATA"
2 - if values exist in sheet "DATA" then copy sheet "TEMPLATE" into
new workbook
3 - name new workbook with the unique value in column E of sheet
"DATA" which will be in same row of existing values
4 - create tabs in new workbook and give them name of column B values
of sheet "DATA" which will also in same row of existing values
5 - put column C and D figures of sheet "DATA" in cells A1 and B1 of
new created tabs
6 - save new create workbook on path "C:\Records"
7 - next until there is no value left in column A of sheet "MAIN"

(bit more detail given below for more understading)

1 - check cell A1 value of sheet "MAIN" (which is "LA1") in column A
of sheet "DATA"
2 - if "LA1" exists in column A of sheet "DATA" then copy sheet
"TEMPLATE" into new workbook
3 - name new workbook with the unique value in column E of sheet
"DATA" coming in same row of value "LA1" (which is "DAVID")
4 - create tabs in new workbook and give them name of column B value
of sheet "DATA" which will also in same row of value "LA1" (which will
be "F01" , "F21 and "G61")
5 - put column C and D figures of sheet "DATA" which are in same row
of values "F01" , "F21" and "G61" in cells A1 and B1 of new created
tabs.
6 - save new create workbook on path "C:\Records"
7 - next until there is no value left in column A of sheet "MAIN"

I'll be very thankful to the friend who can help on this

 

[Patrick Molloy]

This isn't greatly elegent, but should get you started ok...paste the code
into a new module

ALT+F11 opens the VBA editor, the INSERT/MODULE from the menu

Option Explicit

Dim wb As Workbook
Dim ws As Worksheet

Dim source As Range
Const TARGETFOLDER As String = "C:\Records\"
Sub Main()
Dim rw As Long
Set source = ThisWorkbook.Worksheets("data").Range("A:A")
rw = 2


With ThisWorkbook.Worksheets("Main")
Do Until .Cells(rw, 1) = ""

If MatchedItem(.Cells(rw, 1)) Then

Set wb = GetWB(.Cells(rw, "E").Value)
Set ws = GetWS(.Cells(rw, "B").Value)

ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1).Resize(1,
5).Value = _
.Cells(rw, 1).Resize(, 5).Value

wb.Close True
End If

rw = rw + 1
Loop
End With
End Sub

Function MatchedItem(Chrg As String) As Boolean
Dim rec As Long
On Error Resume Next
rec = WorksheetFunction.Match(Chrg, source, False)
MatchedItem = (rec <> 0)
On Error GoTo 0
End Function
Function GetWB(wbName As String) As Workbook
On Error Resume Next
Set wb = Workbooks.Open(TARGETFOLDER & wbName & ".xls")
If Err.Number <> 0 Then
Err.Clear
Set wb = Workbooks.Add(1)
wb.SaveAs TARGETFOLDER & wbName
'ThisWorkbook.Worksheets("Template").Copy wb.Worksheets(1)

End If
Set GetWB = wb

End Function
Function GetWS(wsName As String) As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(wsName)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
ThisWorkbook.Worksheets("Template").Copy wb.Worksheets(1)
wb.Worksheets(1).Name = wsName
Set ws = wb.Worksheets(wsName)
End If
Set GetWS = ws
End Function