CODEWITHSUNDEEP
excelvba
user928700
user928700

Reputation: 63

Move rows of Excel sheet to different csv files

I have an Excel file with multiple columns. Column ContractId has ids of contracts.

enter image description here

I created variable of type dictionary and I have below values in it.

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
 
dict.Add Key:="LCW1", Item:=1
dict.Add Key:="LCW2", Item:=1
dict.Add Key:="LCW3", Item:=2
dict.Add Key:="LCW4", Item:=3
dict.Add Key:="LCW5", Item:=4
dict.Add Key:="LCW6", Item:=4

My aim is move contract data from Excel which have same Item value into a separate csv file.

Meaning
rows related to LCW1 and LCW2 should go to one csv file
rows realted to LCW3 will go to a separate csv file
rows realted to LCW4 will go to a separate csv file
rows related to LCW5 and LCW6 should go to separate csv file

There can be any number of rows in the Excel.

Upvotes: 1

Views: 106

Answers (2)

CDP1802
CDP1802

Reputation: 16174

Using Range.Autofilter

Option Explicit

Sub ExportToCSV()

    Const COL_ID = 4 ' D
    Const ROW_HEADER = 2

    Dim grp(4)
    grp(1) = Array("LCW1", "LCW2")
    grp(2) = Array("LCW3")
    grp(3) = Array("LCW4")
    grp(4) = Array("LCW5", "LCW6")

    Dim wb As Workbook, wbCSV As Workbook
    Dim ws As Worksheet, wsCSV As Worksheet
    Dim rng As Range
    Dim iLastRow As Long, iLastCol As Integer
    Dim sFilename As String, i As Integer
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    ws.AutoFilterMode = False

    ' set filter data range
    With ws
        iLastRow = .Cells(Rows.Count, COL_ID).End(xlUp).Row
        iLastCol = .Cells(ROW_HEADER, Columns.Count).End(xlToLeft).Column
        Set rng = .Cells(ROW_HEADER, 2) _
                  .Resize(iLastRow - ROW_HEADER + 1, iLastCol - 1) ' minus col A
    End With

    ' create blank workbook
    Set wbCSV = Workbooks.Add
    Set wsCSV = wbCSV.Sheets(1)

    ' create csv files
    Application.ScreenUpdating = False
    For i = 1 To UBound(grp)
        
        sFilename = Join(grp(i), "_") & ".csv"
        rng.AutoFilter COL_ID - 1, grp(i), xlFilterValues ' col A blank
        rng.Cells.SpecialCells(xlCellTypeVisible).Copy

        wsCSV.Range("A1").PasteSpecial xlPasteValues
        ActiveWorkbook.SaveAs wb.Path & "/" & sFilename, xlCSV
        wsCSV.Cells.Clear
     
    Next
    wbCSV.Close False
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
   
    MsgBox UBound(grp) & " workbooks created", vbInformation
End Sub

Upvotes: 1

VBasic2008
VBasic2008

Reputation: 54807

Export Rows

Option Explicit

Sub exportRows()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Define Table Data Range.
    Dim rg As Range: Set rg = wb.Worksheets("Sheet1").Range("B2").CurrentRegion
    ' Define Table Data Array.
    Dim Data() As Range: ReDim Data(1 To 4)
    ' Define Data Range.
    Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
    
    Dim n As Long
    
    ' Write Header Row Range references to Data Array.
    For n = 1 To 4
        Set Data(n) = rg.Rows(1)
    Next n
    
    Dim sCell As Range
    
    ' Write Data Row Range references to Data Array.
    For Each sCell In rg.Columns(3).Cells
        Select Case sCell.Value
        Case "LCW1", "LCW2"
            Set Data(1) = Union(Data(1), rg.Rows(sCell.Row))
        Case "LCW3"
            Set Data(2) = Union(Data(2), rg.Rows(sCell.Row))
        Case "LCW4"
            Set Data(3) = Union(Data(3), rg.Rows(sCell.Row))
        Case "LCW5", "LCW6"
            Set Data(4) = Union(Data(4), rg.Rows(sCell.Row))
        End Select
    Next sCell
    
    Application.ScreenUpdating = False
    
    ' Copy Table Ranges to new workbooks, save and close them.
    For n = 1 To 4
        With Workbooks.Add
            Data(n).Copy .Worksheets(1).Range("B2")
            Application.DisplayAlerts = False ' overwrite without confirmation
            .SaveAs ThisWorkbook.Path & "\" & "L" & n & ".csv", xlCSV
            Application.DisplayAlerts = True
            .Close False
        End With
    Next n

    Application.ScreenUpdating = True

End Sub

Upvotes: 0

Related Questions