Export data macro

[sbitaxi]

Hi all:

I'm working on a macro to extract data from a workbook and parse it
out to separate workbooks based on values in column A. I acquired this
from an older post that put the data in separate worksheets. I've been
tweaking it to suit my requirements but it chokes whenever it gets to
the point of copying the data to a new workbook. I suspect it has
something to do with switching between the source and the new
workbook.

This macro first analyzes the data in column A and creates a
collection based on the different values that occur. It then applies a
filter based on those values and copies the data to a new workbook
named using the value in the filter and the current date.


Any suggestions are greatly appreciated.


Steven

Sub CreateWorksheets()

Dim wkbkCurrent As Workbook
Dim wsData As Worksheet
Dim wsFilter As Worksheet
Dim ws As Worksheet
Dim cell As Range
Dim colBranch As New Collection
Dim vntBranch As Variant
Dim lngNumRows As Long
Dim wb As Workbook

Set wkbkCurrent = ActiveWorkbook
Set wsData = wkbkCurrent.Worksheets("CustomKFCDonation")
Set wsFilter = wkbkCurrent.Worksheets("CustomKFCDonation")

Application.StatusBar = "Creating workbooks. Please wait..."
Application.ScreenUpdating = False

'Count the number of rows
lngNumRows = wsData.Range("A" & Rows.Count).End(xlUp).Row

'Create a collection of Branch from values in column A
On Error Resume Next
For Each cell In wsData.Range("A2:A" & lngNumRows)
colBranch.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0

'Filter on each Branch, create workbook,
'save workbook and close workbook
For Each vntBranch In colBranch

'Put the Branch's name into the filter criteria range
wkbkCurrent.Worksheets("CustomKFCDonation").Range("A2").Value
= vntBranch

' Set ws = wkbkCurrent.Worksheets.Add
Set wb = Workbooks.Add

'Change the sheet name
' wb.Name = vntBranch & Format(Now(), "yyyy_mmdd")
ActiveWorkbook.SaveAs vntBranch & Format(Now(), "yyyy_mmdd")

wkbkCurrent.Activate

'Filter the data based on your criteria range
'and copy the filtered data to the new workbook
wkbkCurrent.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=wsFilter.Range("A1:A2"), _
CopyToRange:=wb.Sheets("Sheet1").Range("A1")

Next vntBranch

LeaveSub:

Set colBranch = Nothing
Set cell = Nothing
Set wsData = Nothing
Set ws = Nothing
Set wsFilter = Nothing
Set wkbkCurrent = Nothing

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

 

[Ron de Bruin]

Try
http://www.rondebruin.nl/copy5.htm#workbook

 

[sbitaxi]

Ron to the rescue again: thank you!

It does just what I need. I've tweaked it to suit folder location and
file name conventions here, but nothing you did not already expect.
I've also added a find/replace in the new workbooks to capture line
breaks that transformed into odd characters when copied to the new
workbook - searches for Char(10) and replaces it with Char(10). That
seems to clean it up.

Here's the final macro

Sub Copy_To_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

Application.StatusBar = "Creating workbooks. Please wait..."
Application.ScreenUpdating = False

' Name of the sheet with your data
Set ws1 = Sheets("CustomKFCDonation")

' 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 = ".xlsx": FileFormatNum = 51
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("A1:AP" & Rows.Count)

' Set Field number of the filter column
' This example filters on the first field in the range(change the
field if needed)
' In this case the range starts in A so Field:=1 is column A, 2 =
column B, ......
FieldNum = 1
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
MyPath = "Y:\Communications\Online Fundraising\Tribute\2008\"

' 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 = MyPath & 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)

' Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

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

' Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy

With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and
higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

' Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & cell.Value & "_" &
Format(Now(), "yyyy_mmdd") _
& FileExtStr, FileFormatNum

' Replaces odd line break character with new line breaks
Cells.Replace What:=Chr(10), Replacement:=Chr(10),
LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False

' Changes dates stored as numbers to dates
Columns("D").Select
Selection.NumberFormat = "m/d/yyyy"

' Changes numbers stored as text to numbers
Columns("F:F").Select
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell

' saves the workbook with changes
WSNew.Parent.Save
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
.StatusBar = False
End With
End Sub



Steven

 

[Ron de Bruin]

Hi Steven

You are welcome

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


Ron to the rescue again: thank you!

It does just what I need. I've tweaked it to suit folder location and
file name conventions here, but nothing you did not already expect.
I've also added a find/replace in the new workbooks to capture line
breaks that transformed into odd characters when copied to the new
workbook - searches for Char(10) and replaces it with Char(10). That
seems to clean it up.

Here's the final macro

Sub Copy_To_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

Application.StatusBar = "Creating workbooks. Please wait..."
Application.ScreenUpdating = False

' Name of the sheet with your data
Set ws1 = Sheets("CustomKFCDonation")

' 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 = ".xlsx": FileFormatNum = 51
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("A1:AP" & Rows.Count)

' Set Field number of the filter column
' This example filters on the first field in the range(change the
field if needed)
' In this case the range starts in A so Field:=1 is column A, 2 =
column B, ......
FieldNum = 1
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
MyPath = "Y:\Communications\Online Fundraising\Tribute\2008\"

' 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 = MyPath & 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)

' Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

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

' Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy

With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and
higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

' Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & cell.Value & "_" &
Format(Now(), "yyyy_mmdd") _
& FileExtStr, FileFormatNum

' Replaces odd line break character with new line breaks
Cells.Replace What:=Chr(10), Replacement:=Chr(10),
LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False,
ReplaceFormat:=False

' Changes dates stored as numbers to dates
Columns("D").Select
Selection.NumberFormat = "m/d/yyyy"

' Changes numbers stored as text to numbers
Columns("F:F").Select
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell

' saves the workbook with changes
WSNew.Parent.Save
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
.StatusBar = False
End With
End Sub



Steven