VBA Code For Copying Data From Table

[shinobi]

Hi

I am trying to find the most efficient way to write some VBA code that will achieve the following:

1) I have a large table of data on one sheet (four columns, but perhaps 2,000 rows).
2) Each row of data has a label in the first column that categorises the data in the rest of the row.
3) I have a separate sheet for each category.
4) I'd like to extract the data from the main table into the respective sheets (by label).
5) I'd end up with the category specific sheets with a table of data in each one.

Any ideas how best to do this? Not sure if looping through each row from top to bottom to identify category then copy/paste into relevant sheet is best. Or if there is a more efficient method (maybe using a pivot table; or using the data filter etc).

Thanks!

 

[Herakles]

I spend a lot of time in bed for health resaons so spending time on this, and other posts, distracts me.

I'll go through this later but just for now:

Consider having a seperate sheet / table containing the opening balance for each Category. The summary sheet can look this up.

So.... here we go.

1. Create a worksheet called Balances with three columns, Category, Opening Balance, Prefix and populate with the categories, balances and category prefix as below.

Create a table from this range.

Select cell A1.
Select from the ribbon - Insert, Table
Confirm the range and that the table has headers.
Select Table Design from the ribbon.
Name the table tblBalances on the far left under Table Name:

VBA Code For Copying Data From Table.xlsm
	A	B	C
1	Category	Opening Balance	Prefix
2	Green	751	1
3	Blue	976	2
4	Red	138	3
5	Black	413	4
6	White	969	5
Balances

 

[Herakles]

I spend a lot of time in bed for health resaons so spending time on this, and other posts, distracts me.

I'll go through this later but just for now:

Consider having a seperate sheet / table containing the opening balance for each Category. The summary sheet can look this up.

2. Transactions worksheet.

Create a table from this range.

Select cell A1.
Select from the ribbon - Insert, Table
Confirm the range and that the table has headers.
Select Table Design from the ribbon.
Name the table tblTransactions on the far left under Table Name:

 

[Herakles]

I spend a lot of time in bed for health resaons so spending time on this, and other posts, distracts me.

I'll go through this later but just for now:

Consider having a seperate sheet / table containing the opening balance for each Category. The summary sheet can look this up.

3. Replace the code that you have with this code.

Run the subCopyData procedure.

This code will sort the transactions table, create the category worksheets if they don't exist. (Handy for next year) and insert the
summary at cell H1 in each category sheet.

Let me know how you get on.

Private Sub subCopyData()
Dim arr() As Variant
Dim WsTransactions As Worksheet
Dim i As Integer
Dim tbl As ListObject
Dim Ws As Worksheet
Dim blnExists As Boolean
Dim WsDest As Worksheet
Dim strMsg As String
Dim lngRows As Long
Dim strCategory As String
Dim tblBalances As ListObject
Dim intRow As Long
Dim intPrefix As Integer

    ActiveWorkbook.Save
    
    Set WsTransactions = Worksheets("Transactions")
    
    Call subSortTransactions
    
    WsTransactions.Activate
    
    Set tbl = WsTransactions.ListObjects(1)
    
    arr = Application.WorksheetFunction.Unique(tbl.ListColumns(1).DataBodyRange)

    If tbl.ListColumns(1).DataBodyRange.Rows.Count <> tbl.ListColumns(1).DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count Then
        tbl.DataBodyRange.Select
        Selection.AutoFilter
        WsTransactions.Cells(1).Select
    End If
    
    Set tblBalances = Worksheets("Balances").ListObjects(1)
       
    For i = LBound(arr) To UBound(arr)
    
        strCategory = arr(i, 1)
        
        strMsg = strMsg & vbCrLf & arr(i, 1)
        
        intRow = WorksheetFunction.Match(strCategory, tblBalances.ListColumns("Category").DataBodyRange, 0)
        
        intPrefix = WorksheetFunction.Index(tblBalances.ListColumns("Prefix").DataBodyRange, intRow)
    
        arr(i, 1) = intPrefix & "." & arr(i, 1)
    
        For Each Ws In Worksheets
            If Ws.Name = arr(i, 1) Then
                blnExists = True
                Exit For
            End If
        Next Ws
                
        If Not blnExists Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = arr(i, 1)
        End If
        
        Set WsDest = Worksheets(arr(i, 1))
        
        WsDest.Activate
        
        WsDest.Cells.ClearContents
        
        WsTransactions.ListObjects(1).Range.AutoFilter _
        Field:=1, Criteria1:=strCategory
    
        With WsDest

            .Cells.EntireColumn.ColumnWidth = 5
            
            tbl.Range.SpecialCells(xlCellTypeVisible).Copy
                
            .Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
            
            Application.CutCopyMode = 0
        
            .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "tbl" & strCategory
        
            With .ListObjects(1).Range
                .RowHeight = 30
                .IndentLevel = 1
                .EntireColumn.AutoFit
                .VerticalAlignment = xlCenter
            End With
            
            With .ListObjects(1)
                lngRows = .ListColumns(1).DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count
          
            End With
        
            .Cells(1, 1).Select
            
            With WsDest.Range("A1").CurrentRegion.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = vbBlack
            End With
            
        End With
        
        WsTransactions.Activate
 
        tbl.DataBodyRange.Select
        
        Selection.AutoFilter
        
        Call subCreateSummary(WsDest.Range("H1"), strCategory)
        
    Next i
    
    If WsTransactions.AutoFilterMode Then
        WsTransactions.AutoFilter.ShowAllData
    End If
        
    Application.Goto Reference:=WsTransactions.Cells(1, 1), scroll:=True
    
    ActiveWorkbook.Save
    
    MsgBox UBound(arr) & " category tables created." & vbCrLf & _
        strMsg, vbOKOnly, "Confirmation"
     
End Sub

Private Sub subCreateSummary(rngStart As Range, strCategory As String)
Dim rng As Range
Dim Ws As Worksheet
Dim Q As String
Dim strFormula  As String
Dim strAddress As String
    
    Q = Chr(34)
    
    Set Ws = Worksheets(rngStart.Parent.Name)
    
    strAddress = rngStart.Offset(1, 0).Address(False, False)
    
    Ws.Activate
     
    With rngStart
    
        ' Opening Balance.
        .Offset(1, 1).Formula2 = "=INDEX(tblBalances,MATCH(" & Q & strCategory & Q & ",tblBalances[Category],0),2)"
        
        .Formula2 = "=SUM(tbl" & strCategory & "[Amount])"
        .NumberFormat = "£#,##0"
        
        With .Resize(1, 4)
            .Font.Color = vbWhite
            .Interior.Color = vbBlack
            .Font.Bold = True
        End With
                    
        With .Offset(0, 1).Resize(1, 3)
            .Value = Array("Opening Balance", "Net Movements", "Closing Balance")
        End With
    
        .Offset(1, 0).Formula2 = "=EOMONTH(EDATE(DATE(YEAR(Transactions!$B$2),1,1),SEQUENCE(12,1,0)),0)"
        .Offset(1, 0).Resize(12, 1).NumberFormat = "DD-MMM-YY"
    
        strFormula = "=SUMIFS(tblTransactions[Amount],tblTransactions[Date]," & Q & ">=" & Q & _
            " & DATE(YEAR(" & strAddress & "),MONTH(" & strAddress & "),1),tblTransactions[Date]," & Q & "<=" & Q & " & " & _
            strAddress & ",tblTransactions[Account]," & Q & strCategory & Q & ")"
        
        .Offset(1, 2).Resize(12, 1).Formula2 = strFormula
        
        .Offset(2, 1).Resize(11, 1).Formula2 = "=" & .Offset(1, 3).Address(False, False)
        
        .Offset(1, 3).Resize(12, 1).Formula2 = "=" & rngStart.Offset(1, 1).Address(False, False) & "+" & rngStart.Offset(1, 2).Address(False, False)
        
        With .Offset(1, 1).Resize(12, 3)
            .NumberFormat = "£#,##0.00"
        End With
                
        With .Resize(13, 4)
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = vbBlack
            End With
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .IndentLevel = 1
            .EntireColumn.AutoFit
        End With
            
    End With
            
End Sub

Private Sub subSortTransactions()
Dim tbl As ListObject

   Set tbl = ActiveWorkbook.Worksheets("Transactions").ListObjects(1)

    With tbl
    
        .Sort.SortFields.Clear
        .Sort.SortFields.Add _
            Key:=Range("tblTransactions[Date]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortNormal
       
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
    End With
    
End Sub

 

[shinobi]

Hi - thanks so much for putting this together.

Just sending a holding message to thank you for doing this: have had a hectic start to the week, so haven’t been able to test fully yet - but hope to do so in the next day or so.

Will let you know how I get on - and thanks again.