Append rows into different csv files based on column value

[number15]

Hi,
I'm looking for a solution for this case scenario.

I have an excel file with in a column some names and some csv files, named with same names.
I'm trying a way to extract the rows from the excel file and append them to the proper csv file.

For example, Excel file:

Name,Col2,Col3,Col4
Pippo,x,x,x
Pippo,y,y,y
Pippo,z,z,z
Pluto,a,f,b
Pluto,a,g,b

And following csv files:
Pippo.csv
Col2,Col3,Col4
a,b,f
x,b,v

Pluto.csv
Col2,Col3,Col4
y,s,b
y,s,g

Result should be
Pippo.csv
Col2,Col3,Col4
a,b,f
x,b,v
x,x,x
y,y,y
z,z,z

Pluto.csv
Col2,Col3,Col4
y,s,b
y,s,g
a,f,b
a,g,b

My knowledge of VBA is 0, but I can try to work on it if it's possible to solve this case.
I'm fine also to buy an add-in if exists.

Thanks

 

[number15]

Hi Dante, I'm trying to use the same macro on a different spreadsheet with much more rows (around 15000) and i'm getting "vba runtime error 7 out of memory" on this at this instruction:

ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))

What can be the problem?

 

[number15]

A difference was that this sheet was not formatted as table, but I tried to do it but still getting the same error

 

[DanteAmor]

Try this:

Sub Append_rows_into_csv_files()
  Dim myPath As String, myFile As String, cad As String
  Dim i As Long, j As Long, k As Long, n As Long, m As Long, nmax As Long
  Dim a As Variant, b As Variant, ky As Variant
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:D" & Range("A" & Rows.Count).End(3).Row).Value
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    If dic(a(i, 1)) > nmax Then
      nmax = dic(a(i, 1))
    End If
  Next
  ReDim b(1 To UBound(a, 1), 1 To nmax)

  dic.RemoveAll
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      n = n + 1
      dic(a(i, 1)) = n & "|" & 1
    End If
    n = Split(dic(a(i, 1)), "|")(0)
    m = Split(dic(a(i, 1)), "|")(1)
    b(n, m) = i
    m = m + 1
    dic(a(i, 1)) = n & "|" & m
  Next
  
  myPath = ThisWorkbook.Path & "\"
  For Each ky In dic.keys
    n = Split(dic(ky), "|")(0)
    myFile = myPath & ky & ".csv"
    If Dir(myFile) <> "" Then
      Open myFile For Append As #1
      For k = 1 To UBound(b, 2)
        If b(n, k) = "" Then Exit For
        i = b(n, k)         'get row
        cad = ""
        For j = 2 To UBound(a, 2)
          cad = cad & a(i, j) & ","
        Next
        If cad <> "" Then
          cad = Left(cad, Len(cad) - 1)
          Print #1, cad
        End If
      Next
      Close #1
    End If
  Next
End Sub

 

[number15]

It seems not working: no errors, but it no rows appended in the file.

 

[number15]

Nevermind. I think i've missed the folder.
I'm testing with the old one and splitting in two different sheets it's working, but i've a different problem: i have some text content that can contain punctuation (comma, new line etc).
How I can avoid formatting problems when added in the csv?

 

[number15]

And the text could also contains quotes and double quotes (that they should not be removed).

Since I've another macro that prepare the information in the sheet before running this other macro to append the rows, if it's easier/better I can add the formatting there.

Ps. sorry for multiple messages, just found now the "edit" button

 

[number15]

Update: in the meantime i've formatted manually the text.
Your new script seems ok, just this i think it's wrong

For j = 2 To UBound(a, 2)
          cad = cad & a(i, j) & ","

It's appending from column 2, so i've changed it to 1 (j = 1) and seems ok now.

For the formatting i was thinking to manage it in the export from database, so I think i'm fine at the moment.

Thanks again

 

[number15]

Mmm, it seems there problems with accent.
"Piqué cotton" becomes "Piqu頣otton" (opening with notepad++ is xE9.

Is there a way to keep everything as UTF-8?

 

[DanteAmor]

"Piqué cotton" becomes "Piqu頣otton" (opening with notepad++ is xE9.

I don't have that problem. Maybe it's something in your configuration of your machine, but I don't know where you can check it.
What the macro does is pass the data in text.
It occurs to me, the following enters to open a text file and there you specify that it is UTF-8, so that it remains as default in excel.

Checking the macro, I found an error, try the following macro:

Sub Append_rows_into_csv_files()
  Dim myPath As String, myFile As String, cad As String
  Dim i As Long, j As Long, k As Long, n As Long, m As Long, nmax As Long, y As Long
  Dim a As Variant, b As Variant, ky As Variant
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:D" & Range("A" & Rows.Count).End(3).Row).Value
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    If dic(a(i, 1)) > nmax Then
      nmax = dic(a(i, 1))
    End If
  Next
  ReDim b(1 To UBound(a, 1), 1 To nmax)

  dic.RemoveAll
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 1
    End If
    n = Split(dic(a(i, 1)), "|")(0)
    m = Split(dic(a(i, 1)), "|")(1)
    b(n, m) = i
    m = m + 1
    dic(a(i, 1)) = n & "|" & m
  Next
  
  myPath = ThisWorkbook.Path & "\"
  For Each ky In dic.keys
    n = Split(dic(ky), "|")(0)
    myFile = myPath & ky & ".csv"
    If Dir(myFile) <> "" Then
      Open myFile For Append As #1
      For k = 1 To UBound(b, 2)
        If b(n, k) = "" Then Exit For
        i = b(n, k)         'get row
        cad = ""
        For j = 1 To UBound(a, 2)
          cad = cad & a(i, j) & ","
        Next
        If cad <> "" Then
          cad = Left(cad, Len(cad) - 1)
          Print #1, cad
        End If
      Next
      Close #1
    End If
  Next
End Sub

 

[number15]

I don't know what what's wrong with the previous, but also this one seems fine to me.
I still have the problem with the accents.
For what I found yesterday online they were saying that

CreateObject("Scripting.Dictionary")

doesn't support utf-8, but only

CreateObject("ADODB.Stream")

or something with hashtable does.