Consulting

Results 1 to 5 of 5

Thread: Setting a Dynamic Table Range in a VBA

  1. #1
    VBAX Regular
    Joined
    Jun 2022
    Posts
    16
    Location

    Setting a Dynamic Table Range in a VBA

    I am trying to adjust the below VBA so that after it copies the inputted data into a new sheet it also formats it into a table. Currently, the code sets the table to 30 rows. However, because the data I will input changes from project to project, I would like to set the table range to adjust to the amount of rows in the data after the code has run and each of the sheets have been created. Is there a good way that I can do this? I've had trouble changing the range and usually when I alter it I can't get the table to be created at all. Thank you for your time!Snip of VBA Code.jpg

  2. #2
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,997
    Location
    Please post your code here not an image.
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  3. #3
    VBAX Regular
    Joined
    Jun 2022
    Posts
    16
    Location
    Sub AOverheadSheet()
    'Updated by Extendoffice 2017/11/10
        Dim xRg As Range
        Dim xCell As Range
        Dim I As Long
        Dim J As Long
        Dim K As Long
        I = Worksheets("Main").UsedRange.Rows.Count
        J = Worksheets("Overhead").UsedRange.Rows.Count
        If J = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("Overhead").UsedRange) = 0 Then J = 0
        End If
        Set xRg = Worksheets("Main").Range("B1:B" & I)
        On Error Resume Next
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
            If CStr(xRg(K).Value) < 2000 Then
                xRg(K).EntireRow.Copy Destination:=Worksheets("Overhead").Range("A" & J + 1)
                J = J + 1
            End If
        Next
        Application.ScreenUpdating = True
        Sheets("Overhead").Select
        Range("A1:O30").Select
        Application.CutCopyMode = False
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$O$30"), , xlYes).Name = _
            "Table2"
        Range("Table2[#All]").Select
        ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleMedium6"
        Range("Table2[#All]").Select
        ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleMedium6"
        Columns("A:A").ColumnWidth = 5.16
        Columns("B:B").ColumnWidth = 4.26
        Rows("1:1").RowHeight = 26.1
        Rows("1:1").RowHeight = 30.9
        Range("Table2[[#Headers],[Costcode Description]:[Column1]]").Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Columns("C:C").ColumnWidth = 32
        Columns("D:D").ColumnWidth = 12
        Columns("E:E").ColumnWidth = 15.32
        Columns("F:F").ColumnWidth = 14.16
        Columns("G:G").ColumnWidth = 15.68
        Columns("G:G").ColumnWidth = 17.37
        Columns("H:H").ColumnWidth = 14.74
        Columns("I:I").ColumnWidth = 11.21
        Columns("J:J").ColumnWidth = 12.37
        Columns("K:K").ColumnWidth = 15.05
        Columns("L:L").ColumnWidth = 12.42
        Columns("M:M").ColumnWidth = 9.89
        Columns("N:N").ColumnWidth = 16.68
    End Sub
    Last edited by Paul_Hossler; 06-27-2022 at 01:53 PM. Reason: Added CODE tags - pls use the # icon next time

  4. #4
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    It might be as simple as changing
    Range($A$1:$O$30)
    to
     
    Range(A1).CurrentRegion
    Or to
    UsedRange
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  5. #5
    VBAX Regular
    Joined
    Jun 2022
    Posts
    16
    Location
    That was it! Wow I'd been wrestling with that for days. Thank you so much!

    Final Code

    Sub AOverheadSheet()
    'Updated by Extendoffice 2017/11/10
        Dim xRg As Range
        Dim xCell As Range
        Dim I As Long
        Dim J As Long
        Dim K As Long
        I = Worksheets("Main").UsedRange.Rows.Count
        J = Worksheets("Overhead").UsedRange.Rows.Count
        If J = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("Overhead").UsedRange) = 0 Then J = 0
        End If
        Set xRg = Worksheets("Main").Range("B1:B" & I)
        On Error Resume Next
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
            If CStr(xRg(K).Value) < 2000 Then
                xRg(K).EntireRow.Copy Destination:=Worksheets("Overhead").Range("A" & J + 1)
                J = J + 1
            End If
        Next
        Application.ScreenUpdating = True
        Sheets("Overhead").Select
        Range("A1:O30").Select
        Application.CutCopyMode = False
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
            "Table2"
        Range("Table2[#All]").Select
        ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleMedium6"
        Range("Table2[#All]").Select
        ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleMedium6"
        Columns("A:A").ColumnWidth = 5.16
        Columns("B:B").ColumnWidth = 4.26
        Rows("1:1").RowHeight = 26.1
        Rows("1:1").RowHeight = 30.9
        Range("Table2[[#Headers],[Costcode Description]:[Column1]]").Select
        With Selection
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlBottom
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Columns("C:C").ColumnWidth = 32
        Columns("D:D").ColumnWidth = 12
        Columns("E:E").ColumnWidth = 15.32
        Columns("F:F").ColumnWidth = 14.16
        Columns("G:G").ColumnWidth = 15.68
        Columns("G:G").ColumnWidth = 17.37
        Columns("H:H").ColumnWidth = 14.74
        Columns("I:I").ColumnWidth = 11.21
        Columns("J:J").ColumnWidth = 12.37
        Columns("K:K").ColumnWidth = 15.05
        Columns("L:L").ColumnWidth = 12.42
        Columns("M:M").ColumnWidth = 9.89
        Columns("N:N").ColumnWidth = 16.68
    End Sub
    Last edited by Aussiebear; 06-28-2022 at 06:08 AM. Reason: added code tags to supplied code

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •