• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Split records into Individual Excel Files Based on Value from a Column-VBA

Status
Not open for further replies.

rkbisht2019

New Member
Hi All,
I have records in WorkSheet Named 'FileSep'. I want to split records based on the column value 'StoreName'. First, my macro code will copy all StoreName and paste into
another sheet named 'StoreName' and remove duplicates storename.

Now, my macro code should filter records from 'FileSep' based on value in sheet named 'StoreName'. But, no data is coming. Although, no error is coming.


Please help in this.
Regards,
Ravindra
 

Attachments

AlanSidman

Well-Known Member
Code:
Option Explicit

Sub AddWorksheets()
    Application.ScreenUpdating = False
    Dim i As Long
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("FileSep")
    Set s2 = Sheets("StoreName")
    Dim Last As Long
    Dim sName As String, nName As String
    Last = s2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To Last
        sName = s2.Range("A" & i)
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sName
    Next i
    Dim j As Long, lr As Long, lrt As Long, s3 As Worksheet
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    For j = 2 To lr
        For i = 2 To Last
            If s1.Range("A" & j) = s2.Range("A" & i) Then
                nName = s1.Range("A" & j)
                lrt = Sheets(nName).Range("A" & Rows.Count).End(xlUp).Row
                s1.Range("A" & j & ":H" & j).Copy Sheets(nName).Range("A" & lrt + 1)
                
            End If
        Next i
    Next j
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Completed"
End Sub
 

Attachments

vcoolio

New Member
Hello RK,

Another option:

You don't really need the "Store Name" sheet. The unique store names can be extracted from Column A and temporarily stored in another column in the same sheet with the new sheets created from these unique names. The following code does just that:-

Code:
Option Explicit

Sub Test()

              Dim i As Integer, lr As Long
              Dim sh As Worksheet, ws As Worksheet, ar As Variant
       
Application.ScreenUpdating = False
       
              Set sh = Sheets("FileSep")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("A1:A" & lr).AdvancedFilter 2, , sh.[M1], 1  
              sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)).Sort [M2], 1 
              ar = sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp))
             
       For i = 1 To UBound(ar)
              If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                   
              Set ws = Sheets(CStr(ar(i, 1)))
              ws.UsedRange.Clear
                   
              With sh.[A1].CurrentRegion
                   .AutoFilter 1, ar(i, 1)
                   .Copy ws.[A1]
                   .AutoFilter
             End With
                   ws.Columns.AutoFit
       Next i

             sh.Columns("M").Clear
             sh.Select

Application.ScreenUpdating = True

End Sub
The code temporarily stores the unique names in Column M then sorts them and from there creates the new sheets with the relevant data for each store added.
Column M is then cleared.

I hope that this helps.

Cheerio,
vcoolio.
 

rkbisht2019

New Member
Thanks... I will really appreciate if you can put definition of each line in your code. I mean can give definition at important block of code, it will be easier to learn VBA to me.

Thanks for your valuable time
 

vcoolio

New Member
Hello RK,

Here is the code again with some notes added for you:-

Code:
Option Explicit

Sub Test()

              Dim i As Integer, lr As Long
              Dim sh As Worksheet, ws As Worksheet, ar As Variant
      
Application.ScreenUpdating = False
      
              Set sh = Sheets("FileSep")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("A1:A" & lr).AdvancedFilter 2, , sh.[M1], 1 'Unique values moved temporarily to Column M.
              sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)).Sort [M2], 1  'Sort the unique values. This will speed the code up.
              ar = sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)) 'The array of unique values stored in Column M.
            
       For i = 1 To UBound(ar) 'Begin the loop through the array items.
       'This next section evaluates if the worksheets(based on the names in Column A)already exist. If they don't exist then a new sheet is added _
       and named with a unique value.
              If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                  
              Set ws = Sheets(CStr(ar(i, 1))) 'The variable ws is given values(in this case, the unique sheet names in the array).
              ws.UsedRange.Clear
                  
              With sh.[A1].CurrentRegion 'CurrentRegion is the dataset in the "FileSep" sheet beginning at A1.
                   .AutoFilter 1, ar(i, 1) 'The filter is placed on Column A(1) with the criteria being the array values.
                   .Copy ws.[A1] 'Copies to the newly created individual worksheets starting at A1 and includes the headings.
                   .AutoFilter 'The filter is turmed off.
             End With
                   ws.Columns.AutoFit
       Next i 'Move onto the next array item in the loop.

             sh.Columns("M").Clear 'Column M is cleared of the unique values.
             sh.Select

Application.ScreenUpdating = True

End Sub
Cheerio,
vcoolio.
 

AlanSidman

Well-Known Member
And here is my updated code

Code:
Option Explicit

Sub AddWorksheets()
    Application.ScreenUpdating = False 'Prevent screen from flickering
    Dim i As Long 'set the variable i as a long integer
    Dim s1 As Worksheet, s2 As Worksheet 'identify variable names for sheets
    Set s1 = Sheets("FileSep") 'identify the sheet name
    Set s2 = Sheets("StoreName") 'identify the sheet name to variable
    Dim Last As Long 'set variable Last as a long integer
    Dim sName As String, nName As String 'set variables as string
    Last = s2.Range("A" & Rows.Count).End(xlUp).Row 'find the last row in StoreName
    For i = 2 To Last  'Establish loop to run from second row to last row
        sName = s2.Range("A" & i) 'identify the variable sName
        Sheets.Add After:=Sheets(Sheets.Count) 'Add a new sheet after the last sheet
        Sheets(Sheets.Count).Name = sName 'Name the new sheet for the variable sName
    Next i
    Dim j As Long, lr As Long, lrt As Long, s3 As Worksheet 'set the variables
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row 'find the last row in FileSep
    For j = 2 To lr 'Set the loop to run
        For i = 2 To Last 'set the second loop
            If s1.Range("A" & j) = s2.Range("A" & i) Then 'compare the values in the two sheets
                nName = s1.Range("A" & j) 'the variable nName is taken from the range
                lrt = Sheets(nName).Range("A" & Rows.Count).End(xlUp).Row 'finds the last row in the new sheet
                s1.Range("A" & j & ":H" & j).Copy Sheets(nName).Range("A" & lrt + 1) 'copy and paste to new sheet
                
            End If
        Next i
    Next j
    Application.CutCopyMode = False
    Application.ScreenUpdating = True 'pastes the screen values.
    MsgBox "Completed"
End Sub
 

rkbisht2019

New Member
And here is my updated code

Code:
Option Explicit

Sub AddWorksheets()
    Application.ScreenUpdating = False 'Prevent screen from flickering
    Dim i As Long 'set the variable i as a long integer
    Dim s1 As Worksheet, s2 As Worksheet 'identify variable names for sheets
    Set s1 = Sheets("FileSep") 'identify the sheet name
    Set s2 = Sheets("StoreName") 'identify the sheet name to variable
    Dim Last As Long 'set variable Last as a long integer
    Dim sName As String, nName As String 'set variables as string
    Last = s2.Range("A" & Rows.Count).End(xlUp).Row 'find the last row in StoreName
    For i = 2 To Last  'Establish loop to run from second row to last row
        sName = s2.Range("A" & i) 'identify the variable sName
        Sheets.Add After:=Sheets(Sheets.Count) 'Add a new sheet after the last sheet
        Sheets(Sheets.Count).Name = sName 'Name the new sheet for the variable sName
    Next i
    Dim j As Long, lr As Long, lrt As Long, s3 As Worksheet 'set the variables
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row 'find the last row in FileSep
    For j = 2 To lr 'Set the loop to run
        For i = 2 To Last 'set the second loop
            If s1.Range("A" & j) = s2.Range("A" & i) Then 'compare the values in the two sheets
                nName = s1.Range("A" & j) 'the variable nName is taken from the range
                lrt = Sheets(nName).Range("A" & Rows.Count).End(xlUp).Row 'finds the last row in the new sheet
                s1.Range("A" & j & ":H" & j).Copy Sheets(nName).Range("A" & lrt + 1) 'copy and paste to new sheet
               
            End If
        Next i
    Next j
    Application.CutCopyMode = False
    Application.ScreenUpdating = True 'pastes the screen values.
    MsgBox "Completed"
End Sub
Thanks, but actual I need to import each record into Individual Excel File, whereas above code is splitting records in several sheets in single workbook. Please see if it can be fixed.
 

rkbisht2019

New Member
Hello RK,

Here is the code again with some notes added for you:-

Code:
Option Explicit

Sub Test()

              Dim i As Integer, lr As Long
              Dim sh As Worksheet, ws As Worksheet, ar As Variant
     
Application.ScreenUpdating = False
     
              Set sh = Sheets("FileSep")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("A1:A" & lr).AdvancedFilter 2, , sh.[M1], 1 'Unique values moved temporarily to Column M.
              sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)).Sort [M2], 1  'Sort the unique values. This will speed the code up.
              ar = sh.Range("M2", sh.Range("M" & sh.Rows.Count).End(xlUp)) 'The array of unique values stored in Column M.
           
       For i = 1 To UBound(ar) 'Begin the loop through the array items.
       'This next section evaluates if the worksheets(based on the names in Column A)already exist. If they don't exist then a new sheet is added _
       and named with a unique value.
              If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                 
              Set ws = Sheets(CStr(ar(i, 1))) 'The variable ws is given values(in this case, the unique sheet names in the array).
              ws.UsedRange.Clear
                 
              With sh.[A1].CurrentRegion 'CurrentRegion is the dataset in the "FileSep" sheet beginning at A1.
                   .AutoFilter 1, ar(i, 1) 'The filter is placed on Column A(1) with the criteria being the array values.
                   .Copy ws.[A1] 'Copies to the newly created individual worksheets starting at A1 and includes the headings.
                   .AutoFilter 'The filter is turmed off.
             End With
                   ws.Columns.AutoFit
       Next i 'Move onto the next array item in the loop.

             sh.Columns("M").Clear 'Column M is cleared of the unique values.
             sh.Select

Application.ScreenUpdating = True

End Sub
Cheerio,
vcoolio.
Thanks, but actual I need to import each record into Individual Excel File, whereas above code is splitting records in several sheets in single workbook. Please see if it can be fixed.
 

Marc L

Excel Ninja
Hi, according to your attachment a VBA demonstration for starters (all is yet explained in VBA help, a must read !) :​
Code:
Sub Demo1()
         Dim V, R&
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .SheetsInNewWorkbook = 1
    With Sheet1.[A1].CurrentRegion
        .Columns(1).AdvancedFilter 2, , Sheet2.[A1], True
         With Sheet2.[A1].CurrentRegion:  .Sort .Cells(1), 1, Header:=1:  V = .Value2:  End With
         Workbooks.Add
     For R = UBound(V) To 2 Step -1
         Application.StatusBar = "      Processing store " & V(R, 1)
         ActiveSheet.Name = Left(V(R, 1), 31)
         Sheet2.[A2].Value2 = V(R, 1)
        .AdvancedFilter 2, Sheet2.[A1:A2], [A1]
         [A1].ColumnWidth = .Cells(1).ColumnWidth
         ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & V(R, 1), 51
         ActiveSheet.UsedRange.Clear
     Next
         ActiveWorkbook.Close False
    End With
        .DisplayAlerts = True
        .ScreenUpdating = True
        .StatusBar = False
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 

AlanSidman

Well-Known Member
This code does exactly what you asked for in your original post. Why have you changed your requirements? Why did you not ask for what you want originally instead of wasting our time with a solution you did not want. Sorry, but you have wasted enough of my time. I'm out.
 

Marc L

Excel Ninja
Sorry Alan to partially disagree as​
  • the title of this thread is enough explicit,

  • nothing in the initial post explanation about sheets but yes it should be more elaborated
    'cause of the code in the attachment creating new sheets instead of new workbooks, that's confusing …
 

rkbisht2019

New Member
Hi All,
I have records in WorkSheet Named 'FileSep'. I want to split records based on the column value 'StoreName'. First, my macro code will copy all StoreName and paste into
another sheet named 'StoreName' and remove duplicates storename.

Now, my macro code should filter records from 'FileSep' based on value in sheet named 'StoreName'. But, no data is coming. Although, no error is coming.


Please help in this.
Regards,
Ravindra
Getting Error while exporting excel fie for Zone-North-2
 

Attachments

Marc L

Excel Ninja
As my post #9 demonstration works a treat on my side with the initial attachment​
so you must detail which error on which codeline as I'm a very beginner to guess anything …​
 

Marc L

Excel Ninja
It seems you have some forbidden character in a store name to be saved as a workbook …​
 

rkbisht2019

New Member
It seems you have some forbidden character in a store name to be saved as a workbook …​
Dear, Please check my latest excel file this is very different than previous one. When I run macro records zone wise is excluded in individual Excel files, but as soon as it reaches Zone- North-2, it gets stuck and throw errror. You may try the same at your end. file Name is "PK_DUNNING"
 

Marc L

Excel Ninja
As the code within your post #12 attachment is not mine so it seems to be another question for a new thread ?​
In case your error comes when using my demonstration​
so just replace the forbidden characters - according to Windows help for the files names - from the stores names …​
 

rkbisht2019

New Member
As the code within your post #12 attachment is not mine so it seems to be another question for a new thread ?​
In case your error comes when using my demonstration​
so just replace the forbidden characters - according to Windows help for the files names - from the stores names …​
Yes Sir, it my code. I am helpless. I will really appreciate if someone can fix issue.
 

Marc L

Excel Ninja
So back to post #13 : which error & message and on which codeline ?​
Maybe the solution is already within the error message, just for good enough readers …​
 

Marc L

Excel Ninja
As I don't see your new thread in this VBA Macros forum section, never mind this one is now closed …​
 
Status
Not open for further replies.
Top