Copy and Save in specific way
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
"K" wrote:
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
.
|