I have a Summary workbook which contains a worksheet ("S") with multiple rows of data.
I have a default workbook (default) containing 2 worksheets, "plus" and "minus".
I would like to create a macro that:
1. for every row in the Summary worksheet ("S"), it will open the default workbook and save it as a new workbook with the name listed in Column A, row 1. Then a new workbook with the name A2 and so on, for all rows that have data.
2.Before saving and closing the new workbooks, it should copy range, A10-A20 and paste and transpose to sheet "plus", cell C1, and copy range A30-A40 to sheet "minus", cell C1 , paste and transpose.
3. Save and close new workbook with name of cell A1.
4. Loop for all existing rows in worksheet "A".
Result: New workbooks will be created for all filled rows in the Summary, Sheet "A", and all the chosen data will be copied from the rows to the new workbooks and pasted into the worksheets.
Hi Chris
Can you supply a sample worksheet so we dont have to spend time recreating data?
Purfleet
Hello ,
thank you for replying. I managed to create a code that works for me needs. I am sure it is not the perfect solution but it works.
Sub Main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'On Error GoTo PROC_ERROR
Dim ThisWorkbook As Workbook, NewBook As Workbook
Dim ThisWorksheet As Worksheet, NewWs As Worksheet
Dim i As Integer, j As Integer, k As Integer, ExportCount As Integer
Dim Filename As String
Set ThisWorkbook = Application.Workbooks("Client Summary.xlsm")
Set ThisWorksheet = ThisWorkbook.Sheets("Summary")
ExportCount = 0
For i = 1 To 10
If ThisWorksheet.Cells(i, 1) <> "" Then
Range(Cells(i, 2), Cells(i, 12)).copy
Workbooks.Open Filename:="C:Usersxx1DropboxSHARE FOLDERMaster Client Profile.xlsx"
Set NewBook = Application.Workbooks("Master Client Profile.xlsx")
Sheets("CONTACT SHEETS").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ThisWorkbook.Activate
Sheets("Summary").Select
Range(Cells(i, 2), Cells(i, 6)).copy
NewBook.Activate
Sheets("CONTACT BACKGROUND").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
With NewBook
.Title = ThisWorksheet.Cells(i, 1)
.SaveAs "C:Usersxx1DropboxSHARE FOLDER" & ThisWorksheet.Cells(i, 1) & ".xlsx"
.Close
End With
ExportCount = ExportCount + 1
End If
Next i
End Sub
