PDA

View Full Version : [SOLVED] Multiple concerns with my Sheets



headsniper
11-10-2018, 05:05 PM
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/11169445/error-in-finding-last-used-cell-in-vba/11169920#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.

Paul_Hossler
11-10-2018, 06:34 PM
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

headsniper
11-10-2018, 07:13 PM
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!

headsniper
11-10-2018, 08:20 PM
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

headsniper
11-11-2018, 09:05 AM
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?

Paul_Hossler
11-11-2018, 09:18 AM
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

headsniper
11-11-2018, 10:04 AM
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.

Paul_Hossler
11-11-2018, 12:04 PM
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

headsniper
11-11-2018, 02:49 PM
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!:content:

headsniper
11-12-2018, 03:18 PM
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?

Paul_Hossler
11-12-2018, 04:34 PM
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

headsniper
11-13-2018, 04:33 PM
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!