VBA search loop

[NigelExcel]

I am trying to create a macro that will enable me to search through the sorted values in column A, find all of the cells that contain the same value, and then copy those rows of information to a new file at a specified path and save it as the name of the value.

For example:

A1= cat
A2= cat
A3 = dog
A4 = horse
A5 = horse
A6 = horse

The macro would start in cell A1, find the value of cell A1 in A2, copy the information in rows 1 & 2 to a new file and save it as cat.
Then it would continue the loop in A3, not find any other matching cells, copy the information from row 3 to a new file and save it as dog.
The same process would repeat again for A4-A6 and be saved as horse.

This is a bit beyond my current skill level so any help would be appreciated. Any helpful links would be great as well.

 

[Logit]

You'll need to update the path found in the macro code to match your location there. At present the code is saving to a TEST folder located on my desktop.

Paste the following into a Regular Module :

Option Explicit

Sub ExportRowsToFiles()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Dim uniqueValue As Variant
    Dim destWs As Worksheet
    Dim destWb As Workbook
    Dim filePath As String
    Dim lastRow As Long
    Dim fileName As String
    Dim savePath As String
    
    ' Specify the save path (update this to your desired path)
    savePath = "C:\Users\logit\OneDrive\Desktop\Test\" ' Ensure the folder exists
    
    ' Set the current worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Change if needed
    
    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Define the range with data
    Set rng = ws.Range("A2:A" & lastRow)
    
    ' Create a dictionary to hold unique values
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Collect unique values from column A
    For Each cell In rng
        If Not dict.exists(cell.Value) And cell.Value <> "" Then
            dict.Add cell.Value, True
        End If
    Next cell
    
    ' Loop through each unique value
    For Each uniqueValue In dict.keys
        ' Create a new workbook
        Set destWb = Application.Workbooks.Add
        Set destWs = destWb.Sheets(1)
        
        ' Copy the header row (assuming headers are in row 1)
        ws.Rows(1).Copy Destination:=destWs.Rows(1)
        
        ' Filter and copy rows with the unique value
        For Each cell In rng
            If cell.Value = uniqueValue Then
                ws.Rows(cell.Row).Copy Destination:=destWs.Rows(destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
            End If
        Next cell
        
        ' Create the filename
        fileName = uniqueValue & ".xlsx"
        
        ' Save the new workbook
        destWb.SaveAs fileName:=savePath & fileName, FileFormat:=xlOpenXMLWorkbook
        
        ' Close the workbook
        destWb.Close SaveChanges:=False
    Next uniqueValue
    
    ' Clean up
    Set dict = Nothing
    
    MsgBox "Export complete. Files saved at: " & savePath, vbInformation
End Sub

 

[DanteAmor]

Hi @NigelExcel , Welcome to MrExcel.
(it's the first of the year)

Sub copy_data()
  Dim sh As Worksheet, c As Range, ky As Variant, wb As Workbook, wPath As String, lr As Long
  
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  wPath = ThisWorkbook.Path
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  sh.Rows(1).Insert
  sh.Range("A1").Value = "NAME_"
  lr = sh.Range("A" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("A2:A" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 1, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.Range("A2:A" & lr).EntireRow.Copy Range("A1")  'Change 2 to 1 if you also want to copy the header.
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.Rows(1).Delete
'  sh.ShowAllData
  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Happy new year!!
Dante Amor
----- --

 

[NigelExcel]

You'll need to update the path found in the macro code to match your location there. At present the code is saving to a TEST folder located on my desktop.

Paste the following into a Regular Module :

Option Explicit

Sub ExportRowsToFiles()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Dim uniqueValue As Variant
    Dim destWs As Worksheet
    Dim destWb As Workbook
    Dim filePath As String
    Dim lastRow As Long
    Dim fileName As String
    Dim savePath As String
   
    ' Specify the save path (update this to your desired path)
    savePath = "C:\Users\logit\OneDrive\Desktop\Test\" ' Ensure the folder exists
   
    ' Set the current worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Change if needed
   
    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' Define the range with data
    Set rng = ws.Range("A2:A" & lastRow)
   
    ' Create a dictionary to hold unique values
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' Collect unique values from column A
    For Each cell In rng
        If Not dict.exists(cell.Value) And cell.Value <> "" Then
            dict.Add cell.Value, True
        End If
    Next cell
   
    ' Loop through each unique value
    For Each uniqueValue In dict.keys
        ' Create a new workbook
        Set destWb = Application.Workbooks.Add
        Set destWs = destWb.Sheets(1)
       
        ' Copy the header row (assuming headers are in row 1)
        ws.Rows(1).Copy Destination:=destWs.Rows(1)
       
        ' Filter and copy rows with the unique value
        For Each cell In rng
            If cell.Value = uniqueValue Then
                ws.Rows(cell.Row).Copy Destination:=destWs.Rows(destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
            End If
        Next cell
       
        ' Create the filename
        fileName = uniqueValue & ".xlsx"
       
        ' Save the new workbook
        destWb.SaveAs fileName:=savePath & fileName, FileFormat:=xlOpenXMLWorkbook
       
        ' Close the workbook
        destWb.Close SaveChanges:=False
    Next uniqueValue
   
    ' Clean up
    Set dict = Nothing
   
    MsgBox "Export complete. Files saved at: " & savePath, vbInformation
End Sub

This worked great. Thank you so much for your help!

 

[Logit]

You are welcome. Please respond to DanteAmor as well. Volunteers on this and other forums appreciate some type of feed back
to their efforts.

Thanks.

​

 

[NigelExcel]

Hi @NigelExcel , Welcome to MrExcel.
(it's the first of the year)

Sub copy_data()
  Dim sh As Worksheet, c As Range, ky As Variant, wb As Workbook, wPath As String, lr As Long
 
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  wPath = ThisWorkbook.Path
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  sh.Rows(1).Insert
  sh.Range("A1").Value = "NAME_"
  lr = sh.Range("A" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("A2:A" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 1, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.Range("A2:A" & lr).EntireRow.Copy Range("A1")  'Change 2 to 1 if you also want to copy the header.
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.Rows(1).Delete
'  sh.ShowAllData
  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Happy new year!!
Dante Amor
----- --

Happy New Year! Thanks for your help.For this one to work, do I need to have the current workbook saved in the location I want the new workbooks created?

 

[DanteAmor]

Sorry.
Change this:
wPath = ThisWorkbook.Path

For this:
wPath = ThisWorkbook.Path & "\"

For this one to work, do I need to have the current workbook saved in the location I want the new workbooks created?

It's right. Or set the folder name on this line:
wPath = ThisWorkbook.Path & "\"

For example:
wPath = "C:\work\files" & "\"