How to separate one Excel file into multiple files - part 2

HI Subodh or others ..

Subodh helped me with this and it worked great but can this be modified so that it looks in column B and it only copies the items with items in column B that have 10 characters ?

so if Column B has items with 10 characters , I need only those copied to the new file.
If it helps , all those items in Column B start with XX\    and then seven characters

So if it matches the above then only those will copy Column A and B to the new files.




Sub SplitFile()
Dim swb As Workbook, wb As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, i As Long
Dim FilePath As String, FileName As String
Application.ScreenUpdating = False

Set swb = ThisWorkbook          'Source Workbook
Set sws = swb.Sheets("Sheet1")  'Source Sheet
FilePath = swb.Path & "\"

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr Step 10000
    Set wb = Workbooks.Add
    Set dws = wb.Sheets(1)
    FileName = i & " - " & i + 10000 - 1
    dws.Name = FileName
    sws.Range("A1:B1").Copy dws.Range("A1")
    sws.Range("A" & i).Resize(10000, 2).Copy dws.Range("A2")
    Application.DisplayAlerts = False
    wb.SaveAs FilePath & FileName, 51
    wb.Close True
Next i
Application.ScreenUpdating = True
MsgBox "Task completed!", vbInformation
End Sub

Open in new window

LVL 2
MilesLoganAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Hi,

It is 2:15 AM here so I am logging off now. I will try to tweak the code to get the desired output tomorrow if no one else takes it.
1
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please give this a try...

Sub SplitFileWith10Chars()
Dim swb As Workbook, wb As Workbook
Dim sws As Worksheet, dws As Worksheet, Temp As Worksheet
Dim lr As Long, i As Long, j As Long
Dim FilePath As String, FileName As String
Dim x, y()
With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set swb = ThisWorkbook          'Source Workbook
Set sws = swb.Sheets("Sheet1")  'Source Sheet
FilePath = swb.Path & "\"

Set Temp = Worksheets.Add
Temp.Name = "Temp"

lr = sws.Cells(Rows.Count, 1).End(xlUp).Row

ReDim y(1 To lr, 1 To 2)
x = sws.Range("A1:B" & lr).Value

For i = 2 To UBound(x, 1)
    If Left(x(i, 2), 3) = "XX\" And Len(x(i, 2)) = 10 Then
        j = j + 1
        y(j, 1) = x(i, 1)
        y(j, 2) = x(i, 2)
    End If
Next i

If j = 0 Then
    Application.DisplayAlerts = False
    Temp.Delete
    Exit Sub
End If

Temp.Range("A1").Resize(j, 2).Value = y

lr = Temp.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lr Step 10000
    Set wb = Workbooks.Add
    Set dws = wb.Sheets(1)
    FileName = i & " - " & i + 10000 - 1
    dws.Name = FileName
    Temp.Range("A1:B1").Copy dws.Range("A1")
    Temp.Range("A" & i).Resize(10000, 2).Copy dws.Range("A2")
    Application.DisplayAlerts = False
    wb.SaveAs FilePath & FileName, 51
    wb.Close True
Next i

Application.DisplayAlerts = False
Temp.Delete

With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

MsgBox "Task completed!", vbInformation
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
MilesLoganAuthor Commented:
sorry for the late reply .. thank you so much .. you have been a great help
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome! :)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.