Consulting

Page 1 of 6 1 2 3 ... LastLast
Results 1 to 20 of 104

Thread: Creating Multiple Tables Using Loop in VBA. I still want to add new sheets and add

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location

    Exclamation Creating Multiple Tables Using Loop in VBA. I still want to add new sheets and add

    So, I need to add new sheets and add tables in these new sheets, using vba. As shown in the image below, there are two column Main Category and Sub Category. I want to create new sheet for every Main Category and add tables for every Sub Category based on the sheet it belongs to. Additionally I may add new entries to Main Category and Sub Category, the vba code should add sheet and tables for those as well. The only difference is that I need to create multiple tables on button click and the times that it will list is from the start time that's indicated on the below table to the current time.

    1.jpg

    The Main Category becomes the sheet name and the Sub Categories per Main Category becomes each table's Title/Subject and NOT a header.
    So for example, the first sub category's start time is 1AM and right now let's say it's 4AM. The tables should look like this:

    2.jpg

    If the Sub Category's start time is later than the current time, it should only show the Sub Category's name and the headers. So for example, let's use Main Category 2. It should look like this:

    3.jpg

    This is what I have so far:

            Sub CreateSheetsFromAList()
                Dim MyCell As Range, myRange As Range
                Dim MyCell1 As Range, myRange1 As Range
                Dim WSname As String
                        
                Sheet1.Select
                Range("A2").Select
                Range(ActiveCell, ActiveCell.End(xlDown)).Select
                Set myRange = Selection
                Application.ScreenUpdating = False
                
                 For Each MyCell In myRange
                    If Len(MyCell.Text) > 0 Then
                        'Check if sheet exists
                        If Not SheetExists(MyCell.Value) Then
                        
                            'run new reports code until before Else
                            
                            Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
                            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
                                            
                            WSname = MyCell.Value 'stores newly created sheetname to a string variable
                           
                           
                         End If
                    End If
                                                          
                Next MyCell
               
            End Sub
            
             Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
                Dim sht As Worksheet
            
                 If wb Is Nothing Then Set wb = ThisWorkbook
                 On Error Resume Next
                 Set sht = wb.Sheets(shtName)
                 On Error GoTo 0
                 SheetExists = Not sht Is Nothing
             End Function
            
            Public Sub ChooseSheet(ByVal SheetName As String)
               Sheets(SheetName).Select
            End Sub


    I also posted it here: https://stackoverflow.com/questions/...ng-loop-in-vba

    Please help thank you

  2. #2
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Here's the sample file
    Attached Files Attached Files

  3. #3
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Try:
    Sub blah()
    Dim NewSht As Worksheet
    Set Rng = Sheets("Database").Cells(1).CurrentRegion
    Set Rng = Intersect(Rng, Rng.Offset(1)).Resize(, 1)
    CurrentCat = ""
    For Each cll In Rng.Cells
      If cll.Value <> CurrentCat Then
        If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
        Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
        CurrentCat = cll.Value
      End If
      Set Destn = NewSht.Cells(Rows.Count, "B").End(xlUp).Offset(2)
      With Destn
        .Value = cll.Offset(, 1).Value
        With .Font
          .Name = "Calibri"
          .Size = 11
          .Underline = xlUnderlineStyleSingle
          .Bold = True
        End With
      End With
      Set Destn = Destn.Offset(2)
      Destn.Resize(, 13).Value = Array("Hourly Table", "Column 1", "Column 2", "Column 3", "Column 4", "Column 5", "Column 6", "Column 7", "Column 8", "Column 9", "Column 10", "Column 11", "Column 12")
      Set Destn = Destn.Offset(1)
      StartTime = cll.Offset(, 3).Value
      If TypeName(StartTime) = "String" Then StartTime = TimeValue(StartTime)
      EndTime = cll.Offset(, 4).Value
      If TypeName(EndTime) = "String" Then EndTime = TimeValue(EndTime)
      For hr = StartTime To EndTime Step 1 / 24
        Destn.Value = hr
        Destn.NumberFormat = "hh:mm AM/PM"
        Set Destn = Destn.Offset(1)
      Next hr
    Next cll
    If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
    End Sub
    Notes:
    1. 12AM is midnight, 12PM is noon. You need to get these right on the Database sheet.
    2. If you tell me how you formatted the green areas I'll add that in.

    edit post posting: re-reading your msg#1 of this thread I see I've missed some points - give me some time…
    Last edited by p45cal; 01-07-2020 at 01:06 PM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  4. #4
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Some changes:
    Sub blah()
    Dim NewSht As Worksheet, LastTable As ListObject
    Set Rng = Sheets("Database").Cells(1).CurrentRegion
    Set Rng = Intersect(Rng, Rng.Offset(1)).Resize(, 1)
    'Rng.Select
    CurrentCat = ""
    EndTime = Application.WorksheetFunction.Floor_Math(Time, 1 / 24)
    For Each cll In Rng.Cells
      If cll.Value <> CurrentCat Then
        If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
        Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
        NewSht.Name = cll.Value
        CurrentCat = cll.Value
      End If
      Set Destn = NewSht.Cells(Rows.Count, "B").End(xlUp).Offset(2)
      If Not LastTable Is Nothing Then LastTable.Unlist
      With Destn
        .Value = cll.Offset(, 1).Value
        With .Font
          .Name = "Calibri"
          .Size = 11
          .Underline = xlUnderlineStyleSingle
          .Bold = True
        End With
      End With
      Set Destn = Destn.Offset(2)
      Destn.Resize(, 13).Value = Array("Hourly Table", "Column 1", "Column 2", "Column 3", "Column 4", "Column 5", "Column 6", "Column 7", "Column 8", "Column 9", "Column 10", "Column 11", "Column 12")
      Set Destn = Destn.Offset(1)
      StartTime = cll.Offset(, 3).Value
      If TypeName(StartTime) = "String" Then StartTime = TimeValue(StartTime)
      '  EndTime = cll.Offset(, 4).Value
      '  If TypeName(EndTime) = "String" Then EndTime = TimeValue(EndTime)
      For hr = StartTime To EndTime Step 1 / 24
        Destn.Value = hr
        Destn.NumberFormat = "hh:mm AM/PM"
        Set Destn = Destn.Offset(1)
      Next hr
      Set LastTable = NewSht.ListObjects.Add(xlSrcRange, Destn.Offset(-1).CurrentRegion, , xlYes)
      With LastTable
        .TableStyle = "TableStyleMedium14"
        .ShowTableStyleRowStripes = False
        '.Unlist
      End With
    
    Next cll
    If Not LastTable Is Nothing Then LastTable.Unlist
    If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
    End Sub
    The end time is the current time rounded down to the nearest hour. If you want it rounded up to the nearest hour then change Floor_Math to Ceiling_Math.
    I've had a go at some formatting by temporarily converting to listobjects (Tables) and then converting back to a plain ranges.
    If a sheet already exists, what do you want to happen?

    I'll stop there and wait to hear from you.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  5. #5
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by p45cal View Post
    Some changes:
    Sub blah()
    Dim NewSht As Worksheet, LastTable As ListObject
    Set Rng = Sheets("Database").Cells(1).CurrentRegion
    Set Rng = Intersect(Rng, Rng.Offset(1)).Resize(, 1)
    'Rng.Select
    CurrentCat = ""
    EndTime = Application.WorksheetFunction.Floor_Math(Time, 1 / 24)
    For Each cll In Rng.Cells
      If cll.Value <> CurrentCat Then
        If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
        Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
        NewSht.Name = cll.Value
        CurrentCat = cll.Value
      End If
      Set Destn = NewSht.Cells(Rows.Count, "B").End(xlUp).Offset(2)
      If Not LastTable Is Nothing Then LastTable.Unlist
      With Destn
        .Value = cll.Offset(, 1).Value
        With .Font
          .Name = "Calibri"
          .Size = 11
          .Underline = xlUnderlineStyleSingle
          .Bold = True
        End With
      End With
      Set Destn = Destn.Offset(2)
      Destn.Resize(, 13).Value = Array("Hourly Table", "Column 1", "Column 2", "Column 3", "Column 4", "Column 5", "Column 6", "Column 7", "Column 8", "Column 9", "Column 10", "Column 11", "Column 12")
      Set Destn = Destn.Offset(1)
      StartTime = cll.Offset(, 3).Value
      If TypeName(StartTime) = "String" Then StartTime = TimeValue(StartTime)
      '  EndTime = cll.Offset(, 4).Value
      '  If TypeName(EndTime) = "String" Then EndTime = TimeValue(EndTime)
      For hr = StartTime To EndTime Step 1 / 24
        Destn.Value = hr
        Destn.NumberFormat = "hh:mm AM/PM"
        Set Destn = Destn.Offset(1)
      Next hr
      Set LastTable = NewSht.ListObjects.Add(xlSrcRange, Destn.Offset(-1).CurrentRegion, , xlYes)
      With LastTable
        .TableStyle = "TableStyleMedium14"
        .ShowTableStyleRowStripes = False
        '.Unlist
      End With
    
    Next cll
    If Not LastTable Is Nothing Then LastTable.Unlist
    If Not NewSht Is Nothing Then NewSht.Columns("B:B").EntireColumn.AutoFit
    End Sub
    The end time is the current time rounded down to the nearest hour. If you want it rounded up to the nearest hour then change Floor_Math to Ceiling_Math.
    I've had a go at some formatting by temporarily converting to listobjects (Tables) and then converting back to a plain ranges.
    If a sheet already exists, what do you want to happen?

    I'll stop there and wait to hear from you.

    you are my savior
    If a sheet already exists I will only have to update each tables

  6. #6
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Quote Originally Posted by jazz2409 View Post
    If a sheet already exists I will only have to update each tables
    That could be very convoluted. Is there going to be data in those pre-existing tables? If so what happens to that data? What if the pre-existing table is from another day when it was created at a later time of day?
    I'm not going to be in a hurry to spend lots of time on this one!
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  7. #7
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by p45cal View Post
    That could be very convoluted. Is there going to be data in those pre-existing tables? If so what happens to that data? What if the pre-existing table is from another day when it was created at a later time of day?
    I'm not going to be in a hurry to spend lots of time on this one!
    There will be data on each table. The report will be ran every hour. The data that will be captured for each hour should stay there. And this report is used daily so there will be no data from a different day

  8. #8
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Also how do I set EndTime to get the value of a specific cell? I tried changing your EndTime to this:

    EndTime = ThisWorkbook.Sheets("Scrubber").Range("D1").Value
    cell D1 in sheet Scrubber has a formula of
    =ROUNDDOWN(Scrubber!$B$1*24,0)/24
    It's not working..I need the EndTime to get the value of cell D1

  9. #9
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Quote Originally Posted by jazz2409 View Post
    It's not working..I need the EndTime to get the value of cell D1
    That should work. It depends what's in cell B1 though.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  10. #10
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    re-instate one line:
    EndTime = ThisWorkbook.Sheets("Scrubber").Range("D1").Value
    If TypeName(EndTime) = "String" Then EndTime = TimeValue(EndTime)
    should do it.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  11. #11
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by p45cal View Post
    re-instate one line:
    EndTime = ThisWorkbook.Sheets("Scrubber").Range("D1").Value
    If TypeName(EndTime) = "String" Then EndTime = TimeValue(EndTime)
    should do it.
    Yes I tried that. It works but if it's 12PM, it only shows until 11AM

  12. #12
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Quote Originally Posted by jazz2409 View Post
    Yes I tried that. It works but if it's 12PM, it only shows until 11AM
    Change to:
      For hr = StartTime To EndTime + 0.0001 Step 1 / 24
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  13. #13
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    You've removed the penultimate line:
    If Not LastTable Is Nothing Then LastTable.Unlist
    which means that the last table created remains a listobject (Excel Table).
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  14. #14
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    On the consolidated sheet there are many rows for the same date/time/Lob/SubLob which you seem to want to put on one line in the new sheets. How are you summarising theose multiple rows?
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  15. #15
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    And do you think it will be easier to just pivot the data then put them in the tables rather than use formulas? I noticed that one formula significantly slowed down your code

  16. #16
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Quote Originally Posted by jazz2409 View Post
    And do you think it will be easier to just pivot the data then put them in the tables rather than use formulas? I noticed that one formula significantly slowed down your code
    Pivot what data?
    What formulae?
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  17. #17
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Quote Originally Posted by jazz2409 View Post
    And do you think it will be easier to just pivot the data then put them in the tables rather than use formulas?
    Just addressing this for a moment as a possibility.
    In the attached is a pivot table on Sheet9, which at first sight appears to give the correct answers.
    I need you to check that it's giving the right results, in all the columns, for the various combinations of Lob and SubLob using the slicers or the dropdowns at the top of column B of Sheet9.
    There's not much data in that file, but you can change the source of the Pivot table to a bigger data set to check more thoroughly. The headers need to be exactly the same (at least the ones that are used used in the Pivot).
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  18. #18
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    Quote Originally Posted by p45cal View Post
    Just addressing this for a moment as a possibility.
    In the attached is a pivot table on Sheet9, which at first sight appears to give the correct answers.
    I need you to check that it's giving the right results, in all the columns, for the various combinations of Lob and SubLob using the slicers or the dropdowns at the top of column B of Sheet9.
    There's not much data in that file, but you can change the source of the Pivot table to a bigger data set to check more thoroughly. The headers need to be exactly the same (at least the ones that are used used in the Pivot).
    Everything is correct except for Full AHT. Formula has to be =IF('OB Tasks'=0,'IB AHT'/'IB Tasks',('IB AHT'/'IB Tasks')+(('OB AHT'/'OB Tasks')* ('OB Tasks'/'IB Tasks')))

  19. #19
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Yes, all values are the same.
    All these formulae give the same result:
    Your formula:
    =IF('OB Tasks'=0,'IB AHT'/'IB Tasks',('IB AHT'/'IB Tasks')+(('OB AHT'/'OB Tasks')* ('OB Tasks'/'IB Tasks')))
    Your formula shortened:
    =IF('OB Tasks'=0,'IB AHT'/'IB Tasks',('IB AHT'/'IB Tasks')+('OB AHT'/'IB Tasks'))
    Your formula further shortened:
    ='IB AHT'/'IB Tasks'+IF('OB Tasks'=0,0,'OB AHT'/'IB Tasks')
    my formula:
    =' IB AHT'+' OB AHT'*'OB Tasks'/'IB Tasks'
    Note that some of these references have leading spaces (' IB AHT' & ' OB AHT'); they are different from others ('IB AHT' & 'OB AHT') and refer to other calculated fields in the pivot, so my last formula, although the shortest, is not necessarily more efficient nor the best.

    Now another scenario discovered on your larger data set which might need to be catered for:
    SubLOB Category 1b, Jan 10th 2020, at 6:00,12:00,16:00 & 20:00 have all zero values for IB Tasks (column K of the Consolidated sheet), while all have non-zero values for OB Tasks (Column P).
    They're causing errors at the moment. Do they need dealing with?

    See attached, Sheet9, columns L:O for comparison.
    Attached Files Attached Files
    Last edited by p45cal; 01-10-2020 at 03:07 PM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  20. #20
    VBAX Tutor
    Joined
    Jan 2020
    Posts
    204
    Location
    I have a sheet named Consolidated. It contains all data that I need to compute and segregate to each sub category.

    So what happens in this report is this:

    1) Get raw data from system
    2) Dump to Excel Sheet
    3) Process it and transfer to Consolidated Sheet
    4) Compute for each Sub Category and segregate per hour per sub category
    5) Repeat from 1 throughout the day

Tags for this Thread

Posting Permissions

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