PDA

View Full Version : [SOLVED] Compiling a List to a Seperate Sheet



Nick72310
05-04-2016, 08:09 AM
There is a lot going on here so I will try and explain what I am looking to do the best I can. I have attached my workbook below. This file is just a small example of the "real" file, which I cannot share.
16082

In the file, I have multiple worksheets that contain lists. These lists are complied in column C but have headers every so often that are merged together in columns B:C. There are items that I manually highlight when I use this workbook and I want to copy them all to a separate worksheet. However, there is one other criteria that needs to be addressed. I have a table with a column that contains either the letter "Y" or is blank. If the item is highlighted and contains the letter Y in the table, then I want it copied to the separate worksheet. Otherwise, it should not appear on the separate sheet.

On each sheet, I have named ranges for column B:C if it's needed. My line of thinking was to search the named ranges and if it was highlighted and label "Y" in the table, then it would appear on the separate sheet. I'm not quite sure how to do that though. One thing to note is that the "real" file has a couple thousand lines on each sheet (This # will only increase over time) so I don't want the code to check line by line to see if it gets copied to the other list.

Leith Ross
05-04-2016, 12:56 PM
Hello Nick72310,

The macro below is called by a button on the sheet named "Highlighted & Labeled Y in Tabl". It searches only in columns "B:C" of each worksheet for cells whose color is yellow.

Not every cell is searched because the search is done by using the "Format" option of the search. There are two Dictionary objects to test if the cells have "Y" in the column "B" of the Table. The second dictionary called Headers return the next cell for the column under the header (the worksheet's name) on the "Highlighted & Labeled" worksheet.

Module1 Code


Sub Macro1()

Dim Cell As Range
Dim DstRng As Range
Dim Dict As Object
Dim FirstCell As Range
Dim Header As Range
Dim Headers As Object
Dim Key As String
Dim NextCell As Range
Dim Rng As Range
Dim SrcRng As Range
Dim Wks As Worksheet

Set DstWks = Worksheets("Highlighted & Labeled Y in Tabl")
Intersect(DstWks.UsedRange, DstWks.UsedRange.Offset(1, 0)).ClearContents

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

Set Rng = Worksheets("Table").ListObjects("Table1").DataBodyRange

For Each Cell In Rng.Columns(1).Cells
If Cell.Offset(0, 1) = "Y" Then
If Not Dict.Exists(Cell) Then Dict.Add Cell.Value, ""
End If
Next Cell

Set Headers = CreateObject("Scripting.Dictionary")
Headers.CompareMode = vbTextCompare

For Each Cell In DstWks.Rows(1).Cells
If Cell.Value <> "" Then
If Not Dict.Exists(Cell.Value) Then Headers.Add Cell.Value, Cell.Offset(1, 0)
End If
Next Cell

With Application.FindFormat
.Clear
.Interior.Color = RGB(255, 255, 0)
End With

Application.ScreenUpdating = False

For Each Wks In Worksheets
If Wks.Name <> DstWks.Name Then
Set SrcRng = Wks.UsedRange.Columns("B:C").Cells

' Find cells colored yellow.
Set Cell = SrcRng.Find("*", , xlValues, xlWhole, xlByRows, xlNext, False, False, True)

If Not Cell Is Nothing Then
Set FirstCell = Cell

' Find all yellow colored cells on the worksheet.
Do
DoEvents

If Cell.Value <> "" Then
' Check if yellow cell value is marked with a "Y" in Table.
If Dict.Exists(Cell.Value) Then
Set NextCell = Headers(Wks.Name)
NextCell.Value = Cell.Value
Set Headers(Wks.Name) = NextCell.Offset(1, 0)
End If
End If

' Anymore yellow cells?
Set Cell = SrcRng.Find("*", Cell, xlValues, xlWhole, xlByRows, xlNext, False, False, True)
If Cell.Address = FirstCell.Address Then Exit Do
Loop
End If
End If
Next Wks

Application.FindFormat.Clear
Application.ScreenUpdating = True

End Sub

Nick72310
05-04-2016, 01:53 PM
Thank you Leith Ross!
I was able to make the minimal modifications to consolidate the code into my "real" file. Everything works perfectly!