Macro to import data from one workbook into another & saving

Hi Bad boy,

Name your data sheet as "Data" and your build sheet as "Template" keep them open and try this:

Sub UBooks(): Dim wd As Workbook, wt As Workbook, wb As Workbook
Dim CN As String, CC As Long, DT As String, i As Long, j As Long: i = 2
Dim CPC As String, NPC As String, LOC As String, ASW() As String, n As Integer
Set wd = Workbooks("Data.xlsx"): Set wt = Workbooks("Template.xlsx")

GetUser: n = 1
With wd.Worksheets("Sheet1"): CN = .Cells(i, 2): CC = .Cells(i, 6): DT = .Cells(i, 4)
If CN = "" Then Exit Sub
CPC = .Cells(i, 1): LOC = .Cells(i, 7) & " " & .Cells(i, 8)
Do Until .Cells(i + n, 2) <> CN: n = n + 1: Loop: ReDim ASW(n)
For j = 1 To n: ASW(j) = .Cells(i + j - 1, 10): Next j
End With
wt.Worksheets("Sheet1").Copy: Set wb = ActiveWorkbook
With wb.Worksheets("Sheet1"): .Cells(2, 2) = CN: .Cells(2, 4) = CC: .Cells(2, 6) = DT
.Cells(3, 2) = CPC: .Cells(3, 6) = LOC: For j = 1 To n: .Cells(j + 9, 1) = ASW(j): Next j
End With
wb.SaveAs FileName:=wt.Path & "\" & CN
i = i + n: GoTo GetUser
End Sub

Hi Bad boy,

Thanks for the rep! - I used a temporary book and an array and I didn't code for the autofilter - so, if you manually filter your data:

Sub UBooks(): Dim wd As Workbook, wt As Workbook, wb As Workbook, ws As Worksheet, AF
Dim CN As String, CC As Long, DT As String, i As Long, j As Long: i = 2
Dim CPC As String, NPC As String, LOC As String, ASW() As String, n As Integer
Set wd = Workbooks("Data.xlsx"): Set wt = Workbooks("Template.xlsx")
Workbooks.Add: Set wb = ActiveWorkbook: Set ws = wb.Sheets("Sheet1")
wd.Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
AF = ws.UsedRange.Resize(ws.Range("A" & Rows.Count).End(xlUp).Row + 1, 10)
                wb.Close False: Set wb = Nothing
GetUser: n = 1
 
CN = AF(i, 2): CC = AF(i, 6): DT = AF(i, 4)
If CN = "" Then Exit Sub
CPC = AF(i, 1): LOC = AF(i, 7) & " " & AF(i, 8)
Do Until AF(i + n, 2) <> CN: n = n + 1: Loop: ReDim ASW(n)
For j = 1 To n: ASW(j) = AF(i + j - 1, 10): Next j

wt.Worksheets("Sheet1").Copy: Set wb = ActiveWorkbook
With wb.Worksheets("Sheet1"): .Cells(2, 2) = CN: .Cells(2, 4) = CC: .Cells(2, 6) = DT
.Cells(3, 2) = CPC: .Cells(3, 6) = LOC: For j = 1 To n: .Cells(j + 9, 1) = ASW(j): Next j
End With
wb.SaveAs FileName:=wt.Path & "\" & CN
i = i + n: GoTo GetUser
End Sub

HI Bad boy,

You could try changing:

CC As Long

to:

CC As String

Hmm, when I do that I get "Compile Error: Expected array" at the AF part of CN = AF(i, 2)

This is the code I'm currently using. I made a few little tweaks like changing sheet names and defining the group so the sheets can be saved into specific folders depending on their group. I just can't get it to work with filters.

Sub BuildSheets():
Dim wd As Workbook
Dim wt As Workbook
Dim wb As Workbook
Dim CN As String
Dim CC As String
Dim DT As String
Dim i As Long
Dim j As Long
i = 2
Dim CPC As String
Dim GRP As String
Dim NPC As String
Dim LOC As String
Dim ASW() As String
Dim ToU As String
Dim n As Integer
Dim AF As String

Set wd = Workbooks("Data2.xlsx")
Set wt = Workbooks("Template.xls")

Workbooks.Add: Set wb = ActiveWorkbook: Set ws = wb.Sheets("Sheet1")
wd.Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
AF = ws.UsedRange.Resize(ws.Range("A" & Rows.Count).End(xlUp).Row + 1, 10)
wb.Close False: Set wb = Nothing


GetUser: n = 1
With wd.ActiveSheet: CN = AF(i, 2): CC = AF(i, 10): DT = AF(i, 7): ToU = AF(i, 4): GRP = AF(i, 5)
If CN = "" Then Exit Sub
CPC = AF(i, 1): LOC = AF(i, 11) & " " & AF(i, 12)
Do Until AF(i + n, 2) <> CN: n = n + 1: Loop: ReDim ASW(n)
For j = 1 To n: ASW(j) = AF(i + j - 1, 14): Next j
End With
wt.ActiveSheet.Copy: Set wb = ActiveWorkbook
With wb.Worksheets("Build Sheet"): .Cells(2, 2) = CN: .Cells(2, 4) = CC: .Cells(2, 6) = DT
.Cells(3, 2) = CPC: .Cells(3, 6) = LOC: .Cells(12, 1) = ToU: For j = 1 To n: .Cells(j + 14, 1) = ASW(j): Next j
End With

'Delete blank rows
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Save to Folder by group number
'wb.SaveAs filename:=wt.Path & "\" & "Group" & " " & GRP & "\" & CPC

wb.SaveAs filename:=wt.Path & "\" & CPC

Call CheckA
i = i + n: GoTo GetUser

End Sub

Why did you insert the "With" block:

With wd.ActiveSheet:...End WIth

The array AF must be declared as a variant, so change:

Dim AF As String

To

Dim AF

Hi Bad boy,

Have you a different sample? My sample data sheet has only ten columns

Hi Bad Boy,

I used "Build Sheet" re "Template" and I made the column limit variable:

Sub BuildSheets()
Dim wd As Workbook
Dim wt As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim CN As String
Dim CC As String
Dim DT As String
Dim c As Long
Dim i As Long: i = 2
Dim j As Long
Dim CPC As String
Dim GRP As String
Dim NPC As String
Dim LOC As String
Dim ASW() As String
Dim ToU As String
Dim n As Integer
Dim AF

Set wd = Workbooks("Data2.xlsx")
Set wt = Workbooks("Build Sheet.xlsx")

Workbooks.Add: Set wb = ActiveWorkbook: Set ws = wb.Sheets("Sheet1")
wd.Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
c = ws.Columns.Find("*", , , , xlByColumns, xlPrevious).Column
AF = ws.UsedRange.Resize(ws.Range("A" & Rows.Count).End(xlUp).row + 1, c)
wb.Close False: Set wb = Nothing


GetUser: n = 1
With wd.ActiveSheet: CN = AF(i, 2): CC = AF(i, 10): DT = AF(i, 7): ToU = AF(i, 4): GRP = AF(i, 5)
If CN = "" Then Exit Sub
CPC = AF(i, 1): LOC = AF(i, 11) & " " & AF(i, 12)
Do Until AF(i + n, 2) <> CN: n = n + 1: Loop: ReDim ASW(n)
For j = 1 To n: ASW(j) = AF(i + j - 1, 14): Next j
End With
wt.ActiveSheet.Copy: Set wb = ActiveWorkbook
With wb.Worksheets("Sheet1"): .Cells(2, 2) = CN: .Cells(2, 4) = CC: .Cells(2, 6) = DT
.Cells(3, 2) = CPC: .Cells(3, 6) = LOC: .Cells(12, 1) = ToU: For j = 1 To n: .Cells(j + 14, 1) = ASW(j): Next j
End With

'Delete blank rows
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Save to Folder by group number
'wb.SaveAs filename:=wt.Path & "\" & "Group" & " " & GRP & "\" & CPC

wb.SaveAs FileName:=wt.Path & "\" & CPC

Call CheckA
i = i + n: GoTo GetUser

End Sub

You're welcome and thanks for the rep!