Macro to Create File and Extract, Copy & Paste data in new file.

[Mushtaq86]

Dear All,

Greetings of the Day !!!

Hope you all are having a great time.
I am here trying to trying to Create workbooks from a template file.
The steps are as below:


1. Create new workbooks from the Template file
2. Names of the new workbook are unique cells from column B of the database file. ("assuming column B")
3. Copy the all data related to unique value
4. Paste the copied data in a new file in Range B12


Hope i am not confusing and also not getting very loopy.
Step 1 & 2 have been achieved with the following code.

Sub Create_Workbooks() 
Dim CalcMode As Long 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim WSNew As Worksheet 
Dim rng As Range 
Dim cell As Range 
Dim Lrow As Long 
Dim foldername As String 
Dim MyPath As String 
Dim FieldNum As Integer 
Dim FileExtStr As String 
Dim FileFormatNum As Long 

'Name of the sheet with your data
Set ws1 = Sheets("Summary") '<<< Change

''Copying the Project informtion in the template file
Range("C2:C7").Select 
Selection.Copy 
Workbooks.Open Filename:="C:\Excel Templates\Reinf. for Walls.xlsm" 
Range("C2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
:=False, Transpose:=False 
Range("I12").Select 
Application.CutCopyMode = False 
ActiveWorkbook.SaveAs Filename:= _ 
"C:\Excel Templates\Reinf. for Walls - Temp.xlsm", FileFormat:= _ 
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 
ActiveWorkbook.Save 
ActiveWorkbook.Close 
Range("D10").Select 

'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then 
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143 
Else 
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then 
FileExtStr = ".xls": FileFormatNum = 56 
Else 
FileExtStr = ".xlsm": FileFormatNum = 52 
End If 
End If 

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("B9:AB" & Rows.Count) 

'Set Field number of the filter column
'This example filters on the first field in the range(change the field if needed)
FieldNum = 2 

With Application 
CalcMode = .Calculation 
.Calculation = xlCalculationManual 
.ScreenUpdating = False 
End With 

' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add 

'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "C:\" 

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then 
MyPath = MyPath & "\" 
End If 

'Create folder for the new files
foldername = "C:\All Piers at " & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\" 
MkDir foldername 

With ws2 
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _ 
Action:=xlFilterCopy, _ 
CopyToRange:=.Range("A1"), Unique:=True 

'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row 
For Each cell In .Range("A2:A" & Lrow) 

'Add new workbook with one sheet
'Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Workbooks.Open ("C:\Excel Templates\Reinf. for Walls - Temp.xlsm") 
Set WSNew = ActiveWorkbook.Worksheets(1) 

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False 

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value 

'
'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & cell.Value & FileExtStr, FileFormatNum 
WSNew.Parent.Close False 

'Close AutoFilter
ws1.AutoFilterMode = False 

Next cell 

'Delete the ws2 sheet
On Error Resume Next 
Application.DisplayAlerts = False 
.Delete 
Application.DisplayAlerts = True 
On Error Goto 0 

End With 

MsgBox "Look in " & foldername & " for the files" 

With Application 
.ScreenUpdating = True 
.Calculation = CalcMode 
End With 
'
Range("D10").Select 
End Sub

I want to integrate Step 3 & 4 aswell in the same code.

Thanks for your time in reading this & Many thanks in advance for your guidance.

Cheers !!!

 

[Mushtaq86]

As per the Forum Rules, below is the link for a reference to the same posted by me on another platform.

http://www.ozgrid.com/forum/showthread.php?t=205534&p=799862&posted=1#post799862