Export to CSV files (faster method)

[YasserKhalil]

Hello everyone
Mr. Paul Hossler has already helped me in that code



Sub PaulHossler()
Dim oDict As Object
Dim rData As Range
Dim rTemp As Range
Dim iRow As Long
Dim v As Variant
Dim sKey As String


Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion

For iRow = 2 To rData.Rows.Count
sKey = CStr(rData.Cells(iRow, 1).Value)


If oDict.Exists(sKey) Then
Set rTemp = oDict(sKey)
Set rTemp = Union(rTemp, rData.Rows(iRow))
Set oDict(sKey) = rTemp
Else
oDict.Add sKey, rData.Rows(iRow)
End If
Next iRow


For Each v In oDict.Items
'Here I need to export These rows to CSV file
'But I don't need to use Copy method .. I know
'How to do that in regular way
'I need similar way to dealing with the text files (faster)
Next v


Set oDict = Nothing
End Sub


I have commented out the desired in comments ..
The idea is that I need speed way to export the desired rows to CSV without using copying method
For example : rows 4 - 5 - 8 will be exported to csv with the file name "8"

Thanks advanced for help

[Leith Ross]

Hello Yasser,

This works well. It copies the range into an array and uses the dictionary to combine the lines with the same "key" (value in "A"). Then text lines are then combined into a single text string and output to the file. Change the File to match the file's path and name you are using.



Option Explicit


Sub CreateCSV()


Dim Data As Variant
Dim File As String
Dim j As Long
Dim k As Long
Dim Key As String
Dim Item As Variant
Dim oDict As Object
Dim rngData As Range
Dim Text As String


File = "C:\Test\Yasser.txt"

Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare

Set rngData = ActiveSheet.Cells(1, 1).CurrentRegion

Data = Intersect(rngData, rngData.Offset(0, 1)).Value

For j = 2 To UBound(Data, 1)
Key = rngData.Cells(j, 1).Value

Text = ""

For k = 1 To UBound(Data, 2)
Text = Text & Data(j, k) & ","
Next k

If oDict.Exists(Key) Then
Text = oDict(Key) & Text
oDict(Key) = Text
Else
oDict.Add Key, Key & "," & Text
End If
Next j

Text = ""

For Each Item In oDict.Items
Text = Text & Left(Item, Len(Item) - 1) & vbCrLf
Next Item

Open File For Binary Access Write As #1
Put #1, , Text
Close #1


End Sub

[YasserKhalil]

Thank you very much Mr. Leith
It seems I didn't clarify well .. The export for csv files not to text file (that is a point)
Another point : I need each key to be exported to separate csv file .. and not to combine all the values in the rows for each csv file
The desired csv file would contain three rows (for the key 8 for example)


8
G
H
I


8
J
K
L


8
S
T
U

[Leith Ross]

Hello Yasser,

This modified version will do what asked. Change the Path to where the files will saved.



Option Explicit


Sub CreateCSV_2()


Dim Data As Variant
Dim File As String
Dim j As Long
Dim k As Long
Dim Key As Variant
Dim oDict As Object
Dim Path As String
Dim rngData As Range
Dim Text As String


Path = "C:\Test\"

Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare

Set rngData = ActiveSheet.Cells(1, 1).CurrentRegion

Data = rngData.Value

For j = 2 To UBound(Data, 1)
Key = rngData.Cells(j, 1).Value

Text = ""

For k = 1 To UBound(Data, 2)
Text = Text & Data(j, k) & ","
Next k

Text = Text & vbCrLf

If oDict.Exists(Key) Then
Text = oDict(Key) & Text
oDict(Key) = Text
Else
oDict.Add Key, Text
End If
Next j

Text = ""

For Each Key In oDict.Keys
File = Path & Key & ".csv"
Text = oDict(Key)
Open File For Binary Access Write As #1
Put #1, , Text
Close #1
Next Key


End Sub

[YasserKhalil]

That's amazing amazing .. I am so astonished of this masterpiece
Exactly as I was searching for
Thank you very much for great and incredible help my best tutor

[Leith Ross]

Hello Yasser,

You're most welcome.

[YasserKhalil]

Sorry for disturbing you Mr. Leith
I have in H1 Header dates and in the exported csv files it is not formatted
What modification I could do to format the dates in these new exported csv files?

[YasserKhalil]

I tried this line

data(j, k) = Format(data(j, k), "dd/mm/yyyy")
But I got the format in csv files as "mm/dd/yyyy" ... that is incorrect result
For example : 01 / 03 / 2017 (1st March 2017) .. I found it 03 / 01 / 2017 (3rd January 2017)

[Leith Ross]

Hello Yasser,

Are the dates showing as numbers when you open the CSV?

[YasserKhalil]

No .. When I open CSV file, it looks like dates (no problem in Input file)
But as for the new created CSV file .. this is the problem as it shows as numbers

[Leith Ross]

Hello Yasser,

This should work...


Option Explicit


Sub CreateCSV_3()


Dim Data As Variant
Dim File As String
Dim j As Long
Dim k As Long
Dim Key As Variant
Dim oDict As Object
Dim Path As String
Dim rngData As Range
Dim Text As String


Path = "C:\Test\"

Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare

Set rngData = ActiveSheet.Cells(1, 1).CurrentRegion

Data = rngData.Value

For j = 2 To UBound(Data, 1)
Key = rngData.Cells(j, 1).Value

Text = ""

For k = 1 To UBound(Data, 2)
If IsDate(Data(j, k)) Then
Text = Text & Format(Data(j, k), "dd/mm/yyyy") & ","
Else
Text = Text & Data(j, k) & ","
End If
Next k

Text = Text & vbCrLf

If oDict.Exists(Key) Then
Text = oDict(Key) & Text
oDict(Key) = Text
Else
oDict.Add Key, Text
End If
Next j

Text = ""

For Each Key In oDict.Keys
File = Path & Key & ".csv"
Text = oDict(Key)
Open File For Binary Access Write As #1
Put #1, , Text
Close #1
Next Key


End Sub

[YasserKhalil]

Thanks a lot Mr. Leith for this great solution .. You are awesome and brilliant
Best Regards from the deep of my heart