split workbook into 2 by criteria

[mate02]

Hello Friends:

I have 2 folders having about 200 large files each. I want to split them into 2 workbooks based on two criterias:

For Folder1 files, I want to split all files from Row No 2001, ie first file will have data upto row number 2000 and second file will have data from row number 2001 onwards. The second file will have the same file number as the original but with a suffix 1.

For Folder2 files, I want the macro to look for value "1-Jan-11" in Column A and when this value is found, split the file from here onwards upto the last row and save it as second file with a suffix 1.

I use Excel 2003, have only 1 sheet each in each workbook. Any help would be highly appreciated

[Teeroy]

Hi there,

The aim of this forum is to help you with coding problems, not write the code for you. The code below will do the Folder1 requirement and you can recycle about 75% of it to do Folder2. It's heavily commented to make it easy to follow.

If you have a problem while doing the second code then come back with what you've tried for more help.

Good luck with the coding.

[VBA]
Sub processFiles()

Dim processMe As Boolean
Dim wb As Workbook
Dim newWb As Workbook
Dim rUsedRange As Range
Dim rCutRange As Range
Dim sFileName As String
Dim sFilePath As String
Dim FileFormatNum As Integer

'early Bind
'IMPORTANT: Need to set a VBE reference to Microsoft Scripting Runtime
Dim objFSO As FileSystemObject
Dim fls As Files
Dim f As File

Application.ScreenUpdating = False
'******************************************************************
'Create a FSO to interface to the filesystem.
'Get files collection and step through it
'******************************************************************
Set objFSO = New FileSystemObject
'get Files collection of folder
Set fls = objFSO.GetFolder("C:\Test").Files 'change to correct location
For Each f In fls 'step through files collection
'******************************************************************
'start by assuming the file does not meet criteria
'Only process excel files i.e. ProcessMe = True
'Set fileformatNum to match the original filtype
'******************************************************************
processMe = False
Select Case objFSO.GetExtensionName(f.Path)
Case "xls":
processMe = True
FileFormatNum = 56
Case "xlsx":
processMe = True
FileFormatNum = 51
Case "xlsm":
processMe = True
FileFormatNum = 52
End Select
'******************************************************************
'If it's an excel File open it and check its rows used to
'determine whether it is greater than 2000
'******************************************************************
If processMe Then
Application.Workbooks.Open (f.Path)
Set wb = Workbooks(f.Name)
Set rUsedRange = wb.Sheets(1).UsedRange
If rUsedRange.Cells(rUsedRange.Rows.Count, 1).Row < 2001 Then 'change 20 to 2000
processMe = False
End If
End If
'******************************************************************
'If there's more than 2000 rows cut the extra data and move to
' a new workbook
'******************************************************************
If processMe Then

Set rCutRange = wb.Sheets(1).Range(Cells(2001, rUsedRange.Cells(1, 1).Column), _
rUsedRange.Cells(rUsedRange.Rows.Count, rUsedRange.Columns.Count).Address)
Set newWb = Workbooks.Add(xlWBATWorksheet)
rCutRange.Cut Destination:=newWb.Sheets(1).Range("a1")
'******************************************************************
'Name and save new workbook
'******************************************************************
sFileName = Left(f.Name, Len(f.Name) - (Len(objFSO.GetExtensionName(f.Path)) + 1)) 'remove extension
sFileName = sFileName & "1." & objFSO.GetExtensionName(f.Path) ' append "1" and extension
sFilePath = Left(f.Path, Len(f.Path) - Len(f.Name)) 'extract path of original file

Application.DisplayAlerts = False
With newWb
.SaveAs (sFilePath & sFileName)
.Close SaveChanges:=False
End With
End If
If Not wb Is Nothing Then
Windows(f.Name).Close SaveChanges:=True
End If
Application.DisplayAlerts = True
processMe = False
Set wb = Nothing
Next
Set fls = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True

End Sub
[/VBA]

[snb]

[vba]Sub tst()
c00 = "G:\OF\"
c01 = Dir(c00 & "*.xls*")

Do Until c01 = ""
With GetObject(c00 & c01)
c02 = .FileFormat
.Sheets(1).Copy
With ActiveWorkbook
.Sheets(1).Rows(1).Resize(2000).Delete
.SaveAs c00 & Replace(c01, ".", "_1."), c02
.Close
End With
.Sheets(1).Rows(2001).Resize(.Sheets(1).UsedRange.Rows.Count - 2000).Delete
.Close True
End With
c01 = Dir
Loop
End Sub[/vba]

[Teeroy]

Hi SNB,

Great example; I wouldn't have believed a solution could be pared down to that.

[mate02]

Hi Teeroy and snb:

Thank you very much for your codes. Unfortunately, my PC had a breakdown and I could not access the forum for the last several days, so the delay in reply.

I tried both the codes today. My observations:

Teeroy;s code: The code worked fine. The only problem was that the second suffixed file did not have a header. If this could be added, the code will be fine.

snb's code: The code worked partially. In the sense, it did produce the second suffixed file (but again without a header, Actually it is my fault. I should have mentioned that I want a header for the second file also). The problem with this code is that it renders the original file (but truncated) unusable because neither the file can be opened not can be destroyed until next reboot.

Unfortunately, both your replies came too late (as can be seen by the gap between date of my thread and the replies), so in the meanwhile I have succeded in somehow developing a set of workable codes through Macro Recorder and a loop. The codes are obviously crude but they do work, though taking a little longer than expected. I am giving the codes below:

[VBA]Sub Split_1()
Dim wb As Workbook
Dim XLSPath As String
Dim XLSCount As Integer

XLSPath = "E:\Backup PRS xls\1 Cash scrips\Scrip 1 Raw Xls archive 1994-2012\"

With Application.FileSearch
.LookIn = XLSPath
.FileName = "*.xls"
.Execute

For XLSCount = 1 To .FoundFiles.count
Set wb = Application.Workbooks.Open(.FoundFiles(XLSCount))

Application.Goto Reference:="R2201C1"
Range("A2201:V2201").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Range("A1").Select

wb.SaveAs XLSPath & Left(wb.Name, Len(wb.Name) - 4) & "1" & ".xls"
wb.Close
Next
End With
MsgBox "OK"

End Sub
[/VBA]


[VBA]Sub Split_2()
Dim wb As Workbook
Dim XLSPath As String
Dim XLSCount As Integer

XLSPath = "E:\Backup PRS xls\1 Cash scrips\Scrip 1 Raw Xls archive 1994-2012\"

With Application.FileSearch
.LookIn = XLSPath
.FileName = "*.xls"
.Execute

For XLSCount = 1 To .FoundFiles.count
Set wb = Application.Workbooks.Open(.FoundFiles(XLSCount))

Range("A2:V2100").Select
Selection.EntireRow.Delete
Range("A1").Select

wb.SaveAs XLSPath & Left(wb.Name, Len(wb.Name) - 4) & "2" & ".xls"
wb.Close
Next
End With
MsgBox "OK"

End Sub
[/VBA]

However, all the above codes only address the "Folder1" problem of my thread. Finding a solution to "Folder2" problem is beyond my reach as I have very little knowledge of VBA and would not be in a position to use Find function and develop a macro even through Macro recorder. However, as Teeroy has suggested, I would definately give it a try once again and then come back to you with any problems.

In the meanwhile, I thank you very much for your kind cooperation and understanding.

[snb]

If you had dived into the code:

[VBA]Sub snb()
c00 = "G:\OF\"
c01 = Dir(c00 & "*.xls*")

Do Until c01 = ""
With GetObject(c00 & c01)
c02 = .FileFormat
.Sheets(1).Copy
With ActiveWorkbook
.Sheets(1).Rows(2).Resize(1999).Delete

.application.visible
.SaveAs c00 & Replace(c01, ".", "_1."), c02
.Close
End With
.Sheets(1).Rows(2001).Resize(.Sheets(1).UsedRange.Rows.Count - 2000).Delete
.application.visible
.Close True
End With
c01 = Dir
Loop
End Sub[/VBA]

[mate02]

Hi snb:

Thanks for the modified code. With this new code, the header part is now taken care of. So, suffixed file is quite ok. Again there is a problem with the first (original ) file. When I try to open it, I get a message:

****.xls is already open. Reopening will cause any changes you made to be discarded. Do you want to reopen ****.xls? Then I have to press Yes, then the file opens. Secondly, this file still has full data. It should have only 1999 rows. The rest of the original rows should get deleted.

Another problem with the code is that it stops after the first file with the following error message:

Runtime error 438 : Object doesn't support this property or method. I would suggest you try with some dummy files to get a clear idea. Thanks.

[joecor]

wonderful post. This is one of the best corner i have found in this forum..

________________

[Teeroy]

G'Day Mate (couldn't resist),

Do you have the workbook with the VBA code in the same folder as the files to be modified? This would give you the message that the file is already open when the loop came across it. Also SNBs code assumes that all files you have in the folder meet the criteria you set so there is no checking for no. of rows used. If you have a file that has less than 2000 lines used this would generate an error as you can't resize a range to a negative number.

Hi SNB,

Can you please explain the ".application.visible" statements? I have only seen them used to set or read a Boolean value and can't find any reference to work out how you are using them.

[snb]

[vba]Sub snb()
c00 = "G:\OF\"
c01 = Dir(c00 & "*.xls*")

Do Until c01 = ""
With GetObject(c00 & c01)
c02 = .FileFormat
.Sheets(1).Copy
With ActiveWorkbook

.Sheets(1).Rows(2).Resize(1999).Delete

.SaveAs c00 & Replace(c01, ".", "_1."), c02

.Close
End With
.Sheets(1).Rows(2001).Resize(ABS(.Sheets(1).UsedRange.Rows.Count - 2000)).Delete
.windows(1).visible=True
.Close True
End With
c01 = Dir
Loop

End Sub
[/vba]

You only need the .windows(1).visible=true line to make sure the file will be visible after reopening. Because the method getobject opens a file as a hidden file.I added ABS to prevent a negative resizing.

[mate02]

Hi SNB:
Your latest modified code works just fine.
Thank you very much.


Hi Teeroy:
I have noted your comments and suggestions. I will try to do Folder2 code and come back to you if any problems. Thanks