Loop and Copy/Paste all Rows equaling a variable into a new Excel File

[BibiC]

Hi everyone,

I'm new to vba so will really appreciate any help .
After a long unfruitful search I can't find why my code won't work.

To explain the problem, I have an Excel File with a bunch of data sorted by an index called Prod.Type in column A

[TABLE="width: 500"]
<tbody>[TR]
[TD]Prod.Type[/TD]
[TD]Name[/TD]
[TD]Price[/TD]
[TD]Nb.Stock[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Fries[/TD]
[TD]4[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Roasted Potato[/TD]
[TD]2[/TD]
[TD]50[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Computer[/TD]
[TD]700[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Paper[/TD]
[TD]1[/TD]
[TD]500[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Binder[/TD]
[TD]2[/TD]
[TD]200[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]Chair[/TD]
[TD]40[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]Bag[/TD]
[TD]50[/TD]
[TD]20[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]Panier[/TD]
[TD]50[/TD]
[TD]20[/TD]
[/TR]
</tbody>[/TABLE]

And my code is supposed to :

in a loop to check all Rows value of Prod.Type and
if it equals the variable prodNum then it copy the row into a new excel file.
else it close the file and increment prodNum and loop again until the whole column has been checked.

The result should be like this for prodNum = 2

[TABLE="width: 500"]
<tbody>[TR]
[TD]Prod.Type[/TD]
[TD]Name
[/TD]
[TD]Price[/TD]
[TD]Nb.Stack[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Fries[/TD]
[TD]4[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Roasted Potato[/TD]
[TD]2[/TD]
[TD]50[/TD]
[/TR]
</tbody>[/TABLE]

But the result I get is only the headers row getting paste

Here's the code I have made

Sub test()


    Dim wbtarget As Excel.Workbook
    Dim consh As Worksheet
    Dim prodNum As Long
    Dim i As Long
    Dim shnum As Long
    
    Set consh = ThisWorkbook.Sheets("Sheet1")
    
    For counter = 1 To 20
    
    Set wbtarget = Workbooks.Add
    consh.Rows(1).Copy wbtarget.Sheets(1).Range("A1")
        For i = 1 To ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
            If Range("A" & i).Value = prodNum Then
                consh.Rows("A" & i).Copy wbtarget.Sheets(1).Range("A2")
                    Else
                    wbtarget.SaveAs "C:\Users\Anon\Desktop\Project\" & shnum & ".xlsx" 'path to save file
                    prodNum = prodNum + 1
                    shnum = shnum + 1
            End If
        Next
    Next counter
End Sub

The "For counter = 1 To 20" is for testing purpose, I have more than 6000 rows of data to copy paste.

 

[Fluff]

Hi & welcome to MrExcel
Untested but try

Sub test()
   Dim wbtarget As Workbook
   Dim Consh As Worksheet
   Dim Cl As Range
   
   Set Consh = ThisWorkbook.Sheets("Sheet1")
   With CreateObject("scripting.dictionary")
      For Each Cl In Consh.Range("A2", Consh.Range("A" & Rows.Count).End(xlUp))
         If Not exists(Cl.Value) Then
            Set wbtarget = Workbooks.Add
            .Add Cl.Value, Nothing
            Consh.AutoFilter 1, Cl.Value
            Consh.AutoFilter.Range.Copy wbtarget.Sheets(1).Range("A1")
            wbtarget.SaveAs "C:\Users\Anon\Desktop\Project\" & Cl.Value & ".xlsx" 'path to save file
         End If
      Next Cl
   End With
End Sub

 

[BibiC]

Hi Fluff, thx for your reply

I tested your code, and It give a "Sub or Function not defined" when I run it.

 

[Fluff]

I'm guessing that it was this line that gave the error

If Not exists(Cl.Value) Then

there should be a . in front of Exists. However try this instead.

Sub test()
   Dim wbtarget As Workbook
   Dim Consh As Worksheet
   Dim Cl As Range
   
   Set Consh = ThisWorkbook.Sheets("Sheet1")
   If Consh.AutoFilterMode Then Consh.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In Consh.Range("A2", Consh.Range("A" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            Set wbtarget = Workbooks.Add
            .Add Cl.Value, Nothing
            Consh.Range("A1").AutoFilter 1, Cl.Value
            Consh.AutoFilter.Range.Copy wbtarget.Sheets(1).Range("A1")
            wbtarget.SaveAs "C:\Users\Anon\Desktop\Project\" & Cl.Value & ".xlsx" 'path to save file
         End If
      Next Cl
   End With
   Consh.AutoFilterMode = False
End Sub

There were a couple of other mistakes.

 

[BibiC]

Thx a lot! it works! Thank you so much Fluff!

ah.... there's still one problem..... each newly created excel file don't close after getting all the data, im with 300 opened excel file, and the computer also crashed .

 

[Fluff]

Ok, add this line

            wbTarget.SaveAs "C:\Users\Anon\Desktop\Project\" & Cl.Value & ".xlsx" 'path to save file
            [COLOR=#ff0000]wbTarget.Close False[/COLOR]
         End If

 

[BibiC]

Thank you so much Fluff! My problem is solved, you're a savior !

 

[Fluff]

Glad to help & thanks for the feedback