Look at cell value and split file

jrd21 · Jul 22nd 2012

I have a folder with around 550 lenthy files which I wish to split into 2 files each. All files are in Excel 2003 format and have similar data structure and only 1 worksheet each. Column A contains dates in the format dd-mmm-yy like 31-May-12, 1-Jun-11 etc. The macro should look for a particular date value "30-Dec-04" (please note that in the formula bar, this value reads as 30/12/2004) and when this value is found, split the original file (from A1 position) upto this row as file 1 and from next row (of this date value) till the end of the file as file2. Then delete the original file. For example, if the original file name was ABC.xls then the two new files would be ABC1.xls and ABC2.xls.

I hope my problem is clear and there is no confusion. Help in this respect would be highly appreciated.

Richie(UK) · Jul 22nd 2012

Re: Look at cell value and split file

Hi and welcome to the forum.

Is column A in date order or would the worksheet need to be sorted first?
Is there a set number of columns that is used?
Are the files to be saved in the same folder as the original files?

jrd21 · Jul 23rd 2012

Re: Look at cell value and split file

Hi Richie(UK):

Thanks for your response. All files are sorted on dates in descending order(latest dates on top). All files have data upto column V. New files can be saved in the same folder.

Thanks once again for your kind response.

Richie(UK) · Jul 23rd 2012

Re: Look at cell value and split file

Hi,

OK, first draft suggestion below. Please note that I don't have time to test this at the moment. Given that the code includes file deletion I strongly suggest that you work with a dummy directory and dummy workbooks until the code is working as intended - please exercise care. (I have commented out the deletion line in the code below - probably best to leave it like that until everything else is working as intended).

Code

Sub Main()
    Const strPath As String = "C:\Documents and Settings\Richie\My Documents\Excel\Tests\"
    'define appropriate directory here
    Dim strFile As String


    Application.ScreenUpdating = False
    'speed-up process by not displaying
    
    strFile = Dir(strPath & "*.xls")
    Do While strFile <> ""
        Call Subord(strPath & strFile)
        'Kill strPath & strFile
        strFile = Dir()
    Loop
    'loop through all of the files, call a sub to do our processing, delete the original file
    
    Application.ScreenUpdating = True
    'reset display
    
End Sub


Sub Subord(strFullName As String)
    Const strDate As String = "30/12/2004"
    Dim wbk As Workbook, rngFound As Range, wbkNew As Workbook
    
    Set wbk = Workbooks.Open(strFullName)
    'open the workbook to work with
    
    With wbk.ActiveSheet
        Set rngFound = .Find(what:=DateValue(strDate), LookIn:=xlFormulas)
        'search for date
        If Not rngFound Is Nothing Then
            Set wbkNew = Workbooks.Add
            .Range("A1:V" & rngFound.Row).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
        End If
        'if date found proceed
    End With
    
End Sub

Display More

Richie(UK) · Jul 24th 2012

Re: Look at cell value and split file

OK, a slight change of approach is needed I think - otherwise we will be adding workbooks into the directory that is being processed and that could cause problems. The amended version below uses a function, courtesy of JWalk, to get an array of file names and then process this rather than looping through the directory.

Code

Sub Main()
    Const strPath As String = "C:\Documents and Settings\Richie\My Documents\Excel\Tests\"
     'define appropriate directory here
    Dim x As Variant, i As Integer
     
    Application.ScreenUpdating = False
     'speed-up process by not displaying
     
    x = GetFileList(strPath)
    
    Select Case IsArray(x)
        Case True 'files found
            For i = LBound(x) To UBound(x)
                Call Subord(strPath & x(i))
                'Kill strPath & x(i)
            Next i
        Case False 'no files found
            MsgBox "No matching files"
    End Select
    'loop through all of the files, call a sub to do our processing, delete the original file
      
    Application.ScreenUpdating = True
     'reset display
     
End Sub
 
Function GetFileList(FileSpec As String) As Variant
'JWalk function
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False


    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound


    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function


'   Error handler
NoFilesFound:
    GetFileList = False
End Function


Sub Subord(strFullName As String)
    Const strDate As String = "30/12/2004"
    Dim wbk As Workbook, rngFound As Range, wbkNew As Workbook
     
    Set wbk = Workbooks.Open(strFullName)
     'open the workbook to work with
     
    With wbk.ActiveSheet
        Set rngFound = .Find(what:=DateValue(strDate), LookIn:=xlFormulas)
         'search for date
        If Not rngFound Is Nothing Then
            Set wbkNew = Workbooks.Add
            .Range("A1:V" & rngFound.Row).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
        End If
         'if date found proceed
    End With
     
End Sub

Display More

jrd21 · Jul 24th 2012

Re: Look at cell value and split file

Hi Richie(UK):

Thanks for both your codes. I tried both of them but unfortunately I am getting the following error:
Run-time error '438' Object doesn't support this property or method

Perhaps there is some problem with my file? I am attaching a sample file which you can checkup and use for testing purpose. Especially, please check up the formating of dates column in the file

jrd21 · Jul 24th 2012

Re: Look at cell value and split file

I am sorry I could not upload the file due to some procedural problems. File size is 355 kb. Any other way I can upload the file?

Thanks.

Richie(UK) · Jul 24th 2012

Re: Look at cell value and split file

Hi,

I goofed on the Find part, that's why it gave the error. Try the following replacement:

Code

Sub Subord(strFullName As String)
    Const strDate As String = "12/30/2004"
    Dim wbk As Workbook, rngFound As Range, wbkNew As Workbook
     
    Set wbk = Workbooks.Open(strFullName)
     'open the workbook to work with
     
    With wbk.ActiveSheet.Cells
        Set rngFound = .Find(what:=DateValue(strDate), LookIn:=xlFormulas)
         'search for date
        If Not rngFound Is Nothing Then
            Set wbkNew = Workbooks.Add
            .Range("A1:V" & rngFound.Row).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
            wbk.Close
        End If
         'if date found proceed
    End With
     
End Sub

Display More

jrd21 · Jul 25th 2012

Re: Look at cell value and split file

Hi Richie(UK):

I ran the code on some sample files after incorporating the changes in "Subord" part of the code and the code worked fine without any errors. However, there are 3 small issues which I would like you to look into. 1. Files should be saved in the original folder where the main files are located. (At present the new files get saved in My Document. 2. The suffix 1 & 2 get attached to the extension, instead of file name. 3. Files with suffix "2" does not get header row. (In original files, row 1 is a header) .

Thank you very much once again for this kind help.

jrd21 · Jul 25th 2012

Re: Look at cell value and split file

Hi Richie(UK):

Another small issue that I have observed is that if we decide to delete the original files (by removing the quote mark on the code line), the last file processed doesn't get deleted. It remains open and we get the following error message:
Run-time error '70' Permission denied

The suffix part I was able to resolve this way:
.SaveAs Left(wbk.Name, Len(wbk.Name) - 4) & "1" & ".xls"
.SaveAs Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls"

Thanks

jrd21 · Jul 25th 2012

Re: Look at cell value and split file

Hi Richie(UK):

I am glad to inform you that I was able to solve the saving path issue also, as follows:
.SaveAs wbk.path & "\" & Left(wbk.Name, Len(wbk.Name) - 4) & "1" & ".xls"
.SaveAs wbk.path & "\" & Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls"

Now remains only the header part to be copied in suffix 2 files.

In my earlier post I have mentioned:
"Another small issue that I have observed is that if we decide to delete the original files (by removing the quote mark on the code line), the last file processed doesn't get deleted. It remains open and we get the following error message:
Run-time error '70' Permission denied"

Please ignore this error. This is actually due to the file being smaller than our date criteria.

Thanks

Richie(UK) · Jul 25th 2012

Re: Look at cell value and split file

Hey, you've made some good progress

How about the following:

Code

Sub Subord(strFullName As String)
    Const strDate As String = "12/30/2004"
    Dim wbk As Workbook, rngFound As Range, wbkNew As Workbook
     
    Set wbk = Workbooks.Open(strFullName)
     'open the workbook to work with
    
    With wbk.ActiveSheet.Cells
        Set rngFound = .Find(what:=DateValue(strDate), LookIn:=xlFormulas)
         'search for date
        If Not rngFound Is Nothing Then
            Set wbkNew = Workbooks.Add
            .Range("A1:V" & rngFound.Row).Copy
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "1" & ".xls"
                .Close
            End With
            .Range("A2:V" & rngFound.Row).EntireRow.Delete
            .SaveAs wbk.Path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls"
        End If
         'if date found proceed
    End With
     
End Sub

Display More

jrd21 · Jul 26th 2012

Re: Look at cell value and split file

Dear Richie(UK):

I tried the code with your latest modification. It worked ok for "1" file, but while doing "2" file, it came up with the same error:

Runtime error 438 Object doesn't support this property or method

I was able to solve this problem by making the following changes in the code:

.SaveAs wbk.path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls" replaced with

wbk.SaveAs wbk.path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls"
wbk.Close

But as you will see, mine are very crude (but workable) changes as I do not know much of VBA and these are arrived at by trial and error method :).

Look at cell value and split file

Participate now!

Share