Save the Output in Separate CSV Files

Hi All,
I have the below script which produces output in different cells , I want to be able to save separate CSV files of the output generated.Kindly help. (File Attached)

Sub test()
    Dim a, e, i As Long, myOS, x, y, n As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    myOS = Array(Array("WIN", 50), Array("UNIX", 100), Array("AIX", 100), _
                 Array("Linux", 100), Array("Solaris", 100), Array("etc", 100))
    For Each e In myOS
        dic(e(0)) = Array(Empty, 0, e(1))
    Next
    a = Cells(1).CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If dic.exists(a(i, 2)) Then
            If IsEmpty(dic(a(i, 2))(0)) Then
                ReDim x(1 To 1), y(1 To dic(a(i, 2))(2))
            Else
                x = dic(a(i, 2))(0): y = x(UBound(x))
            End If
            n = dic(a(i, 2))(1) + 1
            If n > dic(a(i, 2))(2) Then
                ReDim Preserve x(1 To UBound(x) + 1)
                ReDim y(1 To dic(a(i, 2))(2)): n = 1
            End If
            y(n) = a(i, 1): x(UBound(x)) = y: dic(a(i, 2)) = Array(x, n, dic(a(i, 2))(2))
        End If
    Next
    Columns("e").ClearContents: n = 3
    For Each e In dic
        x = dic(e)(0)
        If Not IsEmpty(x) Then
            For i = 1 To UBound(x)
                n = n + 1: Cells(n, "e").Value = e & " " & i
                n = n + 1: Cells(n, "e").Value = Join(x(i), ", ")
            Next
            n = n + 1
        End If
    Next
End Sub

Hello aashishni ,

This macro will create CSV files based on the OS name and the limit for the IP addresses to be saved.

Sub SaveAsCSV()

    Dim Cell    As Range
    Dim Counts  As Object
    Dim Data    As Variant
    Dim Dict    As Object
    Dim File    As String
    Dim IP      As String
    Dim Item    As Variant
    Dim Key     As Variant
    Dim Limits  As New Collection
    Dim OS      As String
    Dim Path    As String
    Dim Rng     As Range
    
        Path = "C:\Test"
        Path = IIf(Right(Path, 1) <> "\", Path & "\", Path)
        
        Set Counts = CreateObject("Scripting.Dictionary")
            Counts.CompareMode = vbTextCompare
            
        For Each Item In Array("Win 50", "UNIX 100", "AIX 100", "Linux 100", "Solaris 100")
            Item = Split(Item, " ")
            Limits.Add CLng(Item(1)), Item(0)
            Counts.Add Item(0), 1
        Next Item
        
        Set Rng = Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))
        Set Rng = Rng.Resize(ColumnSize:=1)
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Cell In Rng
                OS = Trim(Cell.Offset(0, 1))
                IP = Trim(Cell)
                If OS <> "" Then
                    If Not Dict.Exists(OS) Then
                        ReDim Data(1)
                        Data(0) = 1
                        Data(1) = IP
                        Dict.Add OS, Data
                    Else
                        Data = Dict(OS)
                        Data(0) = Data(0) + 1
                        Data(1) = Data(1) & "," & IP
                        
                        If Data(0) = Limits(OS) Then
                            File = Path & OS & Counts(OS) & ".csv"
                            Open File For Output As #1
                                Print #1, OS & Counts(OS)
                                Print #1, Data(1)
                            Close #1
                            Counts(OS) = Counts(OS) + 1
                            Dict.Remove OS
                        Else
                            Dict(OS) = Data
                        End If
                   End If
                End If
            Next Cell
        
        For Each Key In Dict.Keys
            Data = Dict(Key)
            File = Path & Key & Counts(Key) & ".csv"
            Open File For Output As #1
                Print #1, Key & Counts(Key)
                Print #1, Data(1)
            Close #1
        Next Key
        
End Sub

Hi aashishni,

Have you seen Rule 8 in: https://www.excelforum.com/forum-rul...rum-rules.html
Please do follow it.

Hello aashishni ,

You need to change the variable Path from "C:\Test" to the folder where you want the files to be saved.

Hello aashishni ,

Here is the amended macro. Change Path before you run the macro.

Sub SaveAsCSV()

    Dim Cell    As Range
    Dim Counts  As Object
    Dim Data    As Variant
    Dim Dict    As Object
    Dim File    As String
    Dim IP      As String
    Dim Item    As Variant
    Dim Key     As Variant
    Dim Limits  As New Collection
    Dim OS      As String
    Dim Path    As String
    Dim Rng     As Range
    
        Path = "C:\Test"
        Path = IIf(Right(Path, 1) <> "\", Path & "\", Path)
        
        Set Counts = CreateObject("Scripting.Dictionary")
            Counts.CompareMode = vbTextCompare
            
        For Each Item In Array("Win 50", "UNIX 100", "AIX 100", "Linux 100", "Solaris 100")
            Item = Split(Item, " ")
            Limits.Add CLng(Item(1)), Item(0)
            Counts.Add Item(0), 1
        Next Item
        
        Set Rng = Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))
        Set Rng = Rng.Resize(ColumnSize:=1)
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Cell In Rng
                OS = Trim(Cell.Offset(0, 1))
                IP = Trim(Cell)
                If OS <> "" Then
                    If Not Dict.Exists(OS) Then
                        ReDim Data(1)
                        Data(0) = 1
                        Data(1) = IP
                        Dict.Add OS, Data
                    Else
                        Data = Dict(OS)
                        Data(0) = Data(0) + 1
                        Data(1) = Data(1) & "," & IP
                        
                        If Data(0) = Limits(OS) Then
                            File = Path & OS & Counts(OS) & ".csv"
                            Open File For Output As #1
                                Print #1, OS & Counts(OS)
                                Print #1, Chr(34) & Data(1) & Chr(34)
                            Close #1
                            Counts(OS) = Counts(OS) + 1
                            Dict.Remove OS
                        Else
                            Dict(OS) = Data
                        End If
                   End If
                End If
            Next Cell
        
        For Each Key In Dict.Keys
            Data = Dict(Key)
            File = Path & Key & Counts(Key) & ".csv"
            Open File For Output As #1
                Print #1, Key & Counts(Key)
                Print #1, Chr(34) & Data(1) & Chr(34)
            Close #1
        Next Key
        
        MsgBox "CSV Files have been saved."
        
End Sub

Hello aashishni,

Here is the updated macro and workbook. The macro let's you select the destination folder. I change it back it want.

Sub SaveAsCSV()

    Dim Cell    As Range
    Dim Counts  As Object
    Dim Data    As Variant
    Dim Dict    As Object
    Dim File    As String
    Dim IP      As String
    Dim Item    As Variant
    Dim Key     As Variant
    Dim Limits  As New Collection
    Dim OS      As String
    Dim Path    As String
    Dim Rng     As Range
    
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show Then Path = .SelectedItems(1) Else Exit Sub
        End With
        
        Path = IIf(Right(Path, 1) <> "\", Path & "\", Path)
        
        Set Counts = CreateObject("Scripting.Dictionary")
            Counts.CompareMode = vbTextCompare
            
        For Each Item In Array("Win 50", "UNIX 100", "AIX 100", "Linux 100", "Solaris 100")
            Item = Split(Item, " ")
            Limits.Add CLng(Item(1)), Item(0)
            Counts.Add Item(0), 1
        Next Item
        
        Set Rng = Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))
        Set Rng = Rng.Resize(ColumnSize:=1)
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Cell In Rng
                OS = Trim(Cell.Offset(0, 1))
                IP = Trim(Cell)
                If IP <> "" Then
                    If OS <> "" Then
                        If Not Dict.Exists(OS) Then
                            ReDim Data(1)
                            Data(0) = 1
                            Data(1) = IP
                            Dict.Add OS, Data
                        Else
                            Data = Dict(OS)
                            Data(0) = Data(0) + 1
                            Data(1) = Data(1) & "," & IP
                        
                            If Data(0) = Limits(OS) Then
                                File = Path & OS & Counts(OS) & ".csv"
                                Open File For Output As #1
                                    Print #1, OS & Counts(OS)
                                    Print #1, Chr(34) & Data(1) & Chr(34)
                                Close #1
                                Counts(OS) = Counts(OS) + 1
                                Dict.Remove OS
                            Else
                                Dict(OS) = Data
                            End If
                        End If
                    End If
                End If
            Next Cell
        
        For Each Key In Dict.Keys
            Data = Dict(Key)
            File = Path & Key & Counts(Key) & ".csv"
            Open File For Output As #1
                Print #1, Key & Counts(Key)
                Print #1, Chr(34) & Data(1) & Chr(34)
            Close #1
        Next Key
        
        MsgBox "CSV files are saved in " & Chr(34) & Path & Chr(34)
        
End Sub

Hello aashishni,

Another satisfied customer! Glad I could help.