Make the worksheet with the data the active sheet and run this. It should save to the same path as the csv. VBA Code: Sub flyguy()
Dim ACS As Range, Z As Long, New_WB As Workbook, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range
Dim Headers() As Variant
Set ACS = ActiveSheet.UsedRange
With ACS
Headers = .Rows(1).Value
Total_Columns = .Columns.Count
End With
Start_Row = 2
Do While Stop_Row <= ACS.Rows.Count
Z = Z + 1
If Z > 1 Then Start_Row = Stop_Row + 1
Stop_Row = Start_Row + 499
With ACS.Rows
If Stop_Row > .Count Then Stop_Row = .Count
End With
With ACS
Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
End With
Set New_WB = Workbooks.Add
With New_WB
With .Worksheets(1)
.Cells(1, 1).Resize(1, Total_Columns) = Headers
.Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
End With
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
.Close
End With
If Stop_Row = ACS.Rows.Count Then Exit Do
Loop
End Sub
Make the worksheet with the data the active sheet and run this. It should save to the same path as the csv. VBA Code: Sub flyguy()
Dim ACS As Range, Z As Long, New_WB As Workbook, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range
Dim Headers() As Variant
Set ACS = ActiveSheet.UsedRange
With ACS
Headers = .Rows(1).Value
Total_Columns = .Columns.Count
End With
Start_Row = 2
Do While Stop_Row <= ACS.Rows.Count
Z = Z + 1
If Z > 1 Then Start_Row = Stop_Row + 1
Stop_Row = Start_Row + 499
With ACS.Rows
If Stop_Row > .Count Then Stop_Row = .Count
End With
With ACS
Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
End With
Set New_WB = Workbooks.Add
With New_WB
With .Worksheets(1)
.Cells(1, 1).Resize(1, Total_Columns) = Headers
.Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
End With
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
.Close
End With
If Stop_Row = ACS.Rows.Count Then Exit Do
Loop
End Sub This is Fantastik!! Thank you so much!!! I have ran a quick test on this and it seems to do exactly what I was looking for in the blink of an eye. Is there a way to save this so every time I open excel I do not have to copy/paste into the module? Will run some more tests after the holiday. I never knew excel was this powerful.
- #4
This is Fantastik!! Thank you so much!!! I have ran a quick test on this and it seems to do exactly what I was looking for in the blink of an eye. Is there a way to save this so every time I open excel I do not have to copy/paste into the module? Will run some more tests after the
holiday. I never knew excel was this powerful. You can place it inside a module in the Personal workbook and run it from there.
- #5
You can place it inside a module in the Personal workbook and run it from there. Placing it there worked as expected thank you.
One additional question. After I run the macro the first time the files are created as expected, File-1,File-2,File-3 etc. If I
get another file and try to run the macro it does not create a new file with an increase the file names such as File-4, File-5 it says --A file name already exists in this location do you want to overwrite it(looks to be putting in in the same location as the first File-1)
Is there a workaround for this? Can the file naming just continue?
If I hit no When I debug the below is highlighted
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z &
".xls", FileFormat:=-4143
- #6
Placing it there worked as expected thank you. VBA Code:
Sub flyguy()
Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range, File_Name As String
Dim Headers() As Variant
Set ACS = ActiveSheet.UsedRange
With ACS
Headers = .Rows(1).Value
Total_Columns = .Columns.Count
End With
File_Name = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls")
On Error GoTo Next_File
Do While Len(File_Name) > 0
If File_Name Like "*file-*" Then
B = CLng(Split(Split(File_Name, "file-")(1), ".xls")(0))
If B > Z Then Z = B
End If
Next_File: On Error GoTo -1
File_Name = Dir
Loop
On Error GoTo 0
Start_Row = 2
Do While Stop_Row <= ACS.Rows.Count
Z = Z + 1
If Z > 1 Then Start_Row = Stop_Row + 1
Stop_Row = Start_Row + 499
With ACS.Rows
If Stop_Row > .Count Then Stop_Row = .Count
End With
With ACS
Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
End With
Set New_WB = Workbooks.Add
With New_WB
With .Worksheets(1)
.Cells(1, 1).Resize(1, Total_Columns) = Headers
.Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
End With
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
.Close
End With
If Stop_Row = ACS.Rows.Count Then Exit Do
Loop
End Sub
One additional question. After I run the macro the first time the files are created as expected, File-1,File-2,File-3 etc. If I get another file and try to run the macro it does not create a new file with an increase the file names such
as File-4, File-5 it says --A file name already exists in this location do you want to overwrite it(looks to be putting in in the same location as the first File-1)
Is there a workaround for this? Can the file naming just continue?
If I hit no When I debug the below is highlighted
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
- #7
VBA Code: Sub flyguy()
Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range, File_Name As String
Dim Headers() As Variant
Set ACS = ActiveSheet.UsedRange
With ACS
Headers = .Rows(1).Value
Total_Columns = .Columns.Count
End With
File_Name = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls")
On Error GoTo Next_File
Do While Len(File_Name) > 0
If File_Name Like "*file-*" Then
B = CLng(Split(Split(File_Name, "file-")(1), ".xls")(0))
If B > Z Then Z = B
End If
Next_File: On Error GoTo -1
File_Name = Dir
Loop
On Error GoTo 0
Start_Row = 2
Do While Stop_Row <= ACS.Rows.Count
Z = Z + 1
If Z > 1 Then Start_Row = Stop_Row + 1
Stop_Row = Start_Row + 499
With ACS.Rows
If Stop_Row > .Count Then Stop_Row = .Count
End With
With ACS
Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
End With
Set New_WB = Workbooks.Add
With New_WB
With .Worksheets(1)
.Cells(1, 1).Resize(1, Total_Columns) = Headers
.Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
End With
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
.Close
End With
If Stop_Row = ACS.Rows.Count Then Exit Do
Loop
End Sub The new code
- #8
Getting an error and the below text is red Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
- #9
Getting an error and the below text is red Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _ add a space after the last comma
- #10
add a space after the last comma did that and get compile error and Sub flyguy() is yellow Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
Sub flyguy()