Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy and Save in specific way
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 . |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Save file with specific name | Excel Discussion (Misc queries) | |||
Copy specific Sheets and save them as a workbook | Excel Programming | |||
How to save a file without overwrite or save a copy? | Setting up and Configuration of Excel | |||
Save to specific location | Excel Discussion (Misc queries) | |||
Save As with specific format | Excel Programming |