Consulting

Results 1 to 12 of 12

Thread: Multiple concerns with my Sheets

  1. #1

    Multiple concerns with my Sheets

    Hi all.

    Hopefully I can make this concise enough.

    I am trying to split up one big data table into smaller tables for easier reading for management. The process to do this takes too long, which is why I am trying to code it. Once I'm done here, I will also build code to simplify sending this via email.

    The process I am doing is hide the unnecessary, filter available data, provide a header for the table, then paste the smaller table into the new sheet. Rinse and repeat until all pieces of data are assembled in the new sheet.

    Somehow, whenever I add the second header, It would either not copy, or it would copy over existing data. Also, the second table does not align right below my header.

    I stopped developing my code at the second table because i should just be copy pasting the remaining code.

    Sub Ecom_Aux_Dumptest()
    
    ' Ecom_Aux_Dump Macro
    ' Automatically copies all required data for Ecom Aux, instead of doing it manually.
    '
    
    
    ' COPY FROM ONE SHEET TO ANOTHER
    ' Sheets("Sheet1").Range("A1:B10").Copy Destination:=Sheets("Sheet2").Range("E1")
    
    
    
    
    ' Codeflow: Set formatting>Copy>Paste>Repeat
    ' DO NOT ACTIVATE OR SELECT SHEETS IN CODE
    ' ADD VALUES INDIRECTLY
    Dim aux As Worksheet
    Dim dump As Worksheet
    Dim LastAux As Long
    Dim LastDump As Long
    
    
    Set aux = Sheets("ECOM AUX")
    Set dump = Sheets("Ecom Aux Macro Dump")
    
    
        With Sheets("ECOM AUX")
        LastAux = .Range("A:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        End With
        
        With Sheets("Ecom Aux Macro Dump")
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        LastDump = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        Else
            LastRow = 1
        End If
        End With
        
    Application.ScreenUpdating = False
    ' Hide columns
        aux.Columns("F:G").EntireColumn.Hidden = True
        
    ' Filter according to color
        aux.Sort.SortFields.Add(aux.Columns("H:H"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 199, 206)
        aux.Range("$A$1:$O$311").AutoFilter Field:=8, Criteria1:=RGB(255, _
            199, 206), Operator:=xlFilterCellColor
            
        If Range("H2").Value > 0 Then
    ' Adding Break text, with formatting
        With dump.Range("A1")
            .Value = "BREAK"
            .Name = "Tahoma"
            .Font.Size = 10
            .Font.Bold = True
            .Interior.Color = RGB(255, 255, 0)
        End With
    
    
    ' Copying and pasting the data
        aux.Range("A1:H" & LastAux).Copy
        dump.Range("A2").PasteSpecial Paste:=xlPasteFormats
        dump.Range("A2").PasteSpecial Paste:=xlPasteValues
        
        End If
        
    ' Clear Filters and Hide Cell
        aux.ShowAllData
        aux.Columns("H:H").EntireColumn.Hidden = True
        
    '>>>>>>>>>>>>>>>>>>>COLUMN I<<<<<<<<<<<<<<<<
    
    
    ' REPEAT Filter according to color
        aux.Sort.SortFields.Add(aux.Columns("I:I"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 199, 206)
        aux.Range("$A$1:$O$311").AutoFilter Field:=8, Criteria1:=RGB(255, _
            199, 206), Operator:=xlFilterCellColor
            
        If Range("I2").Value > 0 Then
    ' Adding Break text, with formatting
        With dump.Range("A1" & LastDump).Offset(2, 0)
        '>>>UPDATE TEXT
            .Value = "COACHING"
            .Name = "Tahoma"
            .Font.Size = 10
            .Font.Bold = True
            .Interior.Color = RGB(255, 255, 0)
        End With
    
    
    ' Copying and pasting the data
        aux.Range("A1:I" & LastAux).Copy
        dump.Range("A1" & LastDump).Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
        dump.Range("A1" & LastDump).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        
        End If
        
    ' Clear Filters and Hide Cell
        aux.ShowAllData
        aux.Columns("I:I").EntireColumn.Hidden = True
        
    ' REPEAT Filter according to color
        aux.Range("$A$1:$O$311").AutoFilter Field:=10, Criteria1:=RGB(255, _
            199, 206), Operator:=xlFilterCellColor
            
            
    
    
    
    
    Application.ScreenUpdating = True
    
    
    End Sub
    I think the way I have found the cell of the last row is not working. I have made multiple attempts to find it, as well as tried many methods, mostly from
    https://stackoverflow.com/questions/...69920#11169920

    If I didn't make sense, I have attached the table here.

    Please help. I screwed my last forum post, hopefully I make it right here.
    Attached Files Attached Files
    Last edited by headsniper; 11-10-2018 at 05:36 PM.

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Try this

    Might need more formatting

    Option Explicit
    
    Dim wsAux As Worksheet, wsDump As Worksheet
    Dim rAux As Range, rCommon As Range
    Dim iOut As Long
    
    Sub Ecom_Aux_Dump()
        Dim iField As Long
        
        Application.ScreenUpdating = False
        
        'init
        Set wsAux = Worksheets("ECOM AUX")
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("ECOM AUX Dump").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Worksheets.Add
        ActiveSheet.Name = "ECOM AUX Dump"
        Set wsDump = ActiveSheet
        
        Set rAux = wsAux.Cells(1, 1).CurrentRegion
        Set rCommon = wsAux.Range("A1:E1")
        
        iOut = 1
        
        For iField = 8 To 15
          Call CopyData(iField)
        Next iField
        Application.ScreenUpdating = True
    End Sub
        
    Private Sub CopyData(i As Long)
        Dim r As Range
        
        If wsAux.AutoFilterMode Then wsAux.AutoFilterMode = False
        
        rAux.Rows(1).AutoFilter
        'in case of no color cells
        On Error GoTo NiceExit
        ' Filter according to color
        rAux.AutoFilter Field:=i, Criteria1:=RGB(255, 199, 206), Operator:=xlFilterCellColor
            
        With wsDump.Cells(iOut, 1)
            .Value = UCase(wsAux.Cells(1, i).Value)
            .Interior.Color = vbYellow
            .Font.Bold = True
        End With
            
        iOut = iOut + 1
        
        Set r = rAux.SpecialCells(xlCellTypeVisible)
        
        Intersect(r, rCommon.EntireColumn).Copy wsDump.Cells(iOut, 1)
        Intersect(r, rAux.Columns(i).EntireColumn).Copy wsDump.Cells(iOut, 6)
                
        wsAux.AutoFilterMode = False
        
        iOut = wsDump.Cells(wsDump.Rows.Count, 1).End(xlUp).Row + 2
            
    NiceExit:
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Wow, it looks great!

    I can only look at the difference between the code.

    I'll figure out how the code works so I can adjust the formatting. I only really got to use VBA for a few hours.

    Thanks Paul!
    Last edited by headsniper; 11-10-2018 at 08:13 PM.

  4. #4
    Sorry, the code didn't work completely well

    After retrying it on the real data, all the headers started popping out. Some of the headers had rows with the last cell having blank data. Only the System Issue Column did not have this issue.

    I think this line is the concern. The table will filter the blanks, and the remaining code continues to copy the data.

    If wsAux.AutoFilterMode Then wsAux.AutoFilterMode = False
    Last edited by headsniper; 11-10-2018 at 08:45 PM.

  5. #5
    I tried editing the if statement to reflect row 2, as well as changed False to 0, but it did not work.

    Is there anything in excel that can trigger going to NiceExit?

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Sorry, the code didn't work completely well

    After retrying it on the real data, all the headers started popping out. Some of the headers had rows with the last cell having blank data. Only the System Issue Column did not have this issue.

    I think this line is the concern. The table will filter the blanks, and the remaining code continues to copy the data.
    The sample data worked OK. If it's not representitive of the real data, update your attachment. It's usually special situations that cause problems that require special handling

    Not sure what "popping out' means

    Did you want "System Issue" column included? Wasn't marked on your sample "How <<<< is supposed to look" worksheet. I added it to new attachment

    This version handles the case where no cells are colored. I removed CF from Uptraining column to test

    There were no blank cells in your test data so I added some


    Try this version




    Private Sub CopyData(i As Long)
        Dim r As Range
        
        If wsAux.AutoFilterMode Then wsAux.AutoFilterMode = False
        
        rAux.Rows(1).AutoFilter
        ' Filter according to color
        rAux.AutoFilter Field:=i, Criteria1:=RGB(255, 199, 206), Operator:=xlFilterCellColor
            
        Set r = rAux.SpecialCells(xlCellTypeVisible)
        
        If Intersect(r, rAux.Columns(i).EntireColumn).Cells.Count > 1 Then
                
            With wsDump.Cells(iOut, 1)
                .Value = UCase(wsAux.Cells(1, i).Value)
                .Interior.Color = vbYellow
                .Font.Bold = True
            End With
                
            iOut = iOut + 1
        
            Intersect(r, rCommon.EntireColumn).Copy wsDump.Cells(iOut, 1)
            Intersect(r, rAux.Columns(i).EntireColumn).Copy wsDump.Cells(iOut, 6)
        End If
                
        wsAux.AutoFilterMode = False
        
        iOut = wsDump.Cells(wsDump.Rows.Count, 1).End(xlUp).Row + 2
            
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  7. #7
    Not sure what "popping out' means
    What I meant was that the first row was still copying despite the data being blank.

    Did you want "System Issue" column included? Wasn't marked on your sample "How <<<< is supposed to look" worksheet.
    System issue was included, but it had no data on it in the attachment, so it was not in the worksheet. Avail time is not included from the attachment. Sorry for the late clarification


    This version handles the case where no cells are colored. I removed CF from Uptraining column to test

    There were no blank cells in your test data so I added some


    Try this version

    The code pretty much fixed everything except some 2 sets pulling up names with blank data. The data does exist in the main file, but the time that shows up is 00:00:00.
    Last edited by headsniper; 11-11-2018 at 10:37 AM.

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    If you change to sample data in the attachment to reflect some of these cases, I'll look again

    Right now, all 'pink' cells are selected. None are 00:00:00 as far as I can see
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  9. #9
    I'll have to check with new data once I go back to work tomorrow.


    Also, I am exporting this to email. I already have the code down for that, but the yellow header is too small for the words, even with the formatting.
    After exporting to Outlook, the words get cut in the middle. Can we set the yellow header to be contained in columns A:C, instead of just A?

    Thanks for taking the time to help, I really appreciate it!
    Last edited by headsniper; 11-11-2018 at 04:29 PM.

  10. #10
    I checked with the real data, and the error disappeared. It might have been a fluke with my excel.

    I would now just like to fix the header for my pages.

    What code can we edit to extend the yellow cell to 2-3 cells?

  11. #11
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    just add the marked line to the second macro


            With wsDump.Cells(iOut, 1)
                .Resize(1, 3).Merge '   <<<<<<<<<
                .Value = UCase(wsAux.Cells(1, i).Value)
                .Interior.Color = vbYellow
                .Font.Bold = True
            End With
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  12. #12
    Thanks a ton Paul!

    I've now managed to shrink down my process from 5-10 minutes down to 2. Those minutes saved are crucial in my line of work.

    I have endorsed this macro to my team, and it is helping us tons!

    Thanks again!

Posting Permissions

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