# VBA to consolidate list



## hwong8848 (Jan 3, 2023)

Hi all! I have a list of task and company names on column D and the respective status in column E in sheet Jan 16.
I'd like to have a button to update a table in the Sheet name Consol, which the heading is the status and I like to return Column D in the table to the end until it reach the # (this row is not static, because I might add new task in-between columns or remove from time to time)

This is the list on Jan 16.
workbook1.xlsxABCDE15BEANon-executive Benchmarking & STI reviewBEA
Non-executive Benchmarking & STI reviewLOST16COSCO ShippingInvestment team pay structureCOSCO SHIPPING
Investment team pay structureClosing17HKICLPay Trend HKICL
Pay Trend Preparing Proposal18HKLand Job Matching+Pay BenchmarkingHKLAND 
Job Matching+Pay BenchmarkingCLOSED19HKMAPay trendHKMA
Pay trendMilestone20HKMCHKMC
CLOSED21HKTDCpay level reviewHKTDC
pay level reviewPreparing Proposal22MPFAPay review + rating distributionMPFA
Pay review + rating distributionClosing23PGSJE + pay rangePGS
JE + pay rangeMIA24Swire Propertiesgrading, pay and benefitsSWIRE PROPERTIES
grading, pay and benefitsMilestone2526AIARemCo AdvisoryAIA
RemCo AdvisorySubmitted / Waiting27AXAAPAC team for a Paris projectAXA
APAC team for a Paris projectNew Project28Bank of China HKPay Assessment for Top ManagementBANK OF CHINA HK
Pay Assessment for Top ManagementLOST29Best AssistantPre-IPO supportBEST ASSISTANT
Pre-IPO supportPreparing Proposal30Chen HsongRemCo meeting supportCHEN HSONG
RemCo meeting supportSubmitted / Waiting31China State Construction EngineeringIncentive/ retention programCHINA STATE CONSTRUCTION ENGINEERING
Incentive/ retention programCLOSED32COSCO ShippingLTICOSCO SHIPPING
LTILOST33Hysan DevelopmentLTI designHYSAN DEVELOPMENT
LTI designMIA34MaximPay philosophy workshopMAXIM
Pay philosophy workshopClosing35Peak ReEC BenchmarkingPEAK RE
EC BenchmarkingNew Project36Phase ScientificLTI ProjectPHASE SCIENTIFIC
LTI ProjectClosing37Prudential plcEC BenchmarkingPRUDENTIAL PLC
EC BenchmarkingClosing38Prudential plcRemCo AdvisoryPRUDENTIAL PLC
RemCo AdvisoryLOST39QCPExecutive benchmark and incentiveQCP
Executive benchmark and incentiveSubmitted / Waiting40RPDA2022 data collectionRPDA
2022 data collectionPreparing Proposal41Shui On LandExec benchmark and LTI designSHUI ON LAND
Exec benchmark and LTI designSubmitted / Waiting42SOCAMLTI design workSOCAM
LTI design workContracting43StarHubTotal comp reviewSTARHUB
Total comp reviewMilestone44Swiss ReEC BenchmarkingSWISS RE
EC BenchmarkingLOST4546BEA (Bank of East Asia)EESBEA (BANK OF EAST ASIA)
EESNew Project47CCBAEES - Internal Support ServicesCCBA
EES - Internal Support ServicesLOST48CMHKEES CMHK
EES Submitted / Waiting49DFSComms Support on Rewards OfferingDFS
Comms Support on Rewards OfferingCLOSED50Eaton HKEES licenseEATON HK
EES licenseClosing51Huatai Financial HoldingsEES License + VFGHUATAI FINANCIAL HOLDINGS
EES License + VFGCLOSED52Langham Hotel GroupEES LANGHAM HOTEL GROUP
EES Closing53Mandarin Oriential Hotel GroupEESMANDARIN ORIENTIAL HOTEL GROUP
EESInitial Discussion54PGSLeadership developmentPGS
Leadership developmentContracting55VitasoyEESVITASOY
EESPreparing Proposal5657AIAbenchmarking of IA positionsAIA
benchmarking of IA positionsInitial Discussion58ALDI Asia LimitedSurvey+focus groupALDI ASIA LIMITED
Survey+focus groupPreparing Proposal59AnimocaBrandsJob levellingANIMOCABRANDS
Job levellingSubmitted / Waiting60ASMgrading structure validationASM
grading structure validationPreparing Proposal61Aureconpay competitive analysis & STI reviewAURECON
pay competitive analysis & STI reviewPreparing Proposal62Automated Systems LimitedEESAUTOMATED SYSTEMS LIMITED
EESMIA63BDX EESBDX 
EESNew Project64CCBASaville assessmentCCBA
Saville assessmentSubmitted / Waiting65China Harbour Eng HKGrading structure, perf mgmt, comp reviewCHINA HARBOUR ENG HK
Grading structure, perf mgmt, comp reviewPreparing Proposal66China Investment Holdings Limited CHINA INVESTMENT HOLDINGS LIMITED 
Preparing Proposal67China Resources CapitalInvestment team setupCHINA RESOURCES CAPITAL
Investment team setupSubmitted / Waiting68CityU VMCEESCITYU VMC
EESSubmitted / Waiting69CLP EESCLP 
EESMIA70Cyberportpay benefitCYBERPORT
pay benefitPreparing Proposal71ESFInt'l SchoolESF
Int'l SchoolContracting72Fusion BankLTI Plan DesignFUSION BANK
LTI Plan DesignCLOSED73GDSTBCGDS
TBCCLOSED74GEGEmployee Experience Strategy and Listening ApproachGEG
Employee Experience Strategy and Listening ApproachSubmitted / Waiting75Global GloryTotal comp strategy designGLOBAL GLORY
Total comp strategy designNew Project76HarrowSponsor surveyHARROW
Sponsor surveyNew Project77HK Electricpay benchmarkingHK ELECTRIC
pay benchmarkingContracting78HKJCPay + STIHKJC
Pay + STIClosing79HKSTPPHASE 2: Pay philosophy & GradingHKSTP
PHASE 2: Pay philosophy & GradingCLOSED80HKSTPInvestment team pay structureHKSTP
Investment team pay structureSubmitted / Waiting81HSBCSurveyHSBC
SurveyMilestone82Hysan DevelopmentLTI designHYSAN DEVELOPMENT
LTI designPreparing Proposal83IQAX (OOCL)Pay benchmarking for IT jobsIQAX (OOCL)
Pay benchmarking for IT jobsClosing84KMBPay ReviewKMB
Pay ReviewSubmitted / Waiting85LCSDJob PricingLCSD
Job PricingNew Project86Lee Kam KeeEESLEE KAM KEE
EESSubmitted / Waiting87Maxim'sEESMAXIM'S
EESLOST88MeiyumeRewards StrategyMEIYUME
Rewards StrategyPreparing Proposal89Paul Y EngineeringEESPAUL Y ENGINEERING
EESMIA90PreneticsJob pricingPRENETICS
Job pricingLOST91Qatar Investment AuthoritySTI & Incentive designQATAR INVESTMENT AUTHORITY
STI & Incentive designPreparing Proposal92Sompojob matchingSOMPO
job matchingSubmitted / Waiting93Swire PropertiesEESSWIRE PROPERTIES
EESContracting94Taishin (TW)PulseTAISHIN (TW)
PulseClosing95VingroupLTI designVINGROUP
LTI designMilestone96YWCASaville assessmentYWCA
Saville assessmentPreparing Proposal97#####98INTERNAL STUFF99xx100xxxx101x102xxx103xxx104Jan 16Cell FormulasRangeFormulaD15:D24,D57:D96,D46:D55,D26:D44D15=UPPER(B15)&"
"&C15Cells with Data ValidationCellAllowCriteriaE15:E24List=MISC!$A$2:$A$11E57:E96List=MISC!$A$2:$A$11E46:E55List=MISC!$A$2:$A$11E26:E44List=MISC!$A$2:$A$11

And this is the Consol table as example, the macro has to clear everything each time it updates to avoid duplicating data or misplacing it.
Since my list of task and company names is forever expanding, i need the macro to add new rolls or delete empty rolls as I update it every week as well.

workbook1.xlsxBCDEFGH2Initial DiscussionPreparing ProposalSubmitted / WaitingContractingNew ProjectMilestoneClosing3COSCO SHIPPING
Investment team pay structureCHINA STATE CONSTRUCTION ENGINEERING
Incentive/ retention programBEA
Non-executive Benchmarking & STI review4HKICL
Pay Trend 56789101112131415MIALOSTCLOSED16171819202122Consol

Much Appreciated!


----------



## DanteAmor (Jan 4, 2023)

Try this:


```
Sub Consol()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim st1 As Variant, st2 As Variant
  Dim i As Long, lr As Long, nRow As Long, lr1 As Long, lr2 As Long
  Dim c As Range, f As Range
  
  Set sh1 = Sheets("Jan 16")
  Set sh2 = Sheets("Consol")
  
  Set f = sh1.Range("E:E").Find("#", , xlValues, xlPart, xlByRows, xlPrevious)
  If Not f Is Nothing Then lr = f.Row - 1 Else lr = sh1.Range("E" & Rows.Count).End(3).Row
  
  st1 = Array("Initial Discussion", "Preparing Proposal", "Submitted / Waiting", "Contracting", "New Project", "Milestone", "Closing")
  st2 = Array("", "MIA", "LOST", "", "", "", "CLOSED")
  
  Application.ScreenUpdating = False
  sh2.Cells.Clear
  sh2.Range("B2").Resize(1, UBound(st1) + 1).Value = st1
  sh2.Range("J2").Resize(1, UBound(st2) + 1).Value = st2
    
  For Each c In sh1.Range("E2", sh1.Range("E" & Rows.Count).End(3))
    If c.Value <> "" Then
      Set f = sh2.Range("2:2").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        nRow = sh2.Cells(Rows.Count, f.Column).End(3).Row + 1
        sh2.Cells(nRow, f.Column).Value = c.Offset(, -1).Value
      End If
    End If
  Next
  
  Set f = sh2.Range("B:H").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr1 = f.Row + 2
  
  Set f = sh2.Range("J:P").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr2 = f.Row
  
  sh2.Range("J2:P" & lr2).Cut sh2.Range("B" & lr1)

  With sh2.Range("B2:H2")
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  
  With sh2.Range("B" & lr1 & ":H" & lr1)
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  
  With sh2.Range("B:H")
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With

  Application.ScreenUpdating = True
End Sub
```


----------



## hwong8848 (Jan 4, 2023)

Works great!! Few questions though
I have input some code to create boarder on my table, not sure this is the best way - hope you can let me know!!
Furthermore, is there a way to sort the list by alphabetical order before pasting in the table?


```
Sub Consol()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim st1 As Variant, st2 As Variant
  Dim i As Long, lr As Long, nRow As Long, lr1 As Long, lr2 As Long
  Dim c As Range, f As Range
  
  Set sh1 = ActiveSheet
  Set sh2 = Sheets("Consol")
  
  Set f = sh1.Range("E:E").Find("#", , xlValues, xlPart, xlByRows, xlPrevious)
  If Not f Is Nothing Then lr = f.Row - 1 Else lr = sh1.Range("E" & Rows.Count).End(3).Row
  
  st1 = Array("Initial Discussion", "Preparing Proposal", "Submitted / Waiting", "Contracting", "New Project", "Milestone", "Closing")
  st2 = Array("", "MIA", "LOST", "", "", "", "CLOSED")
  
  Application.ScreenUpdating = False
  sh2.Cells.Clear
  sh2.Range("B2").Resize(1, UBound(st1) + 1).Value = st1
  sh2.Range("J2").Resize(1, UBound(st2) + 1).Value = st2
    
  For Each c In sh1.Range("E2", sh1.Range("E" & Rows.Count).End(3))
    If c.Value <> "" Then
      Set f = sh2.Range("2:2").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        nRow = sh2.Cells(Rows.Count, f.Column).End(3).Row + 1
        sh2.Cells(nRow, f.Column).Value = c.Offset(, -1).Value
      End If
    End If
  Next
  
  Set f = sh2.Range("B:H").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr1 = f.Row + 2
  
  Set f = sh2.Range("J:P").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr2 = f.Row
  
  sh2.Range("J2:P" & lr2).Cut sh2.Range("B" & lr1)

  With sh2.Range("B2:H2")
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  
  With sh2.Range("B" & lr1 & ":H" & lr1)
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  
  With sh2.Range("B:H")
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With

Dim iRange As Range
Dim iCells As Range

Set iRange = sh2.UsedRange
'Format with boarder
For Each iCells In iRange
    If Not IsEmpty(iCells) Then
    iCells.BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin
    End If
Next iCells

  Application.ScreenUpdating = True
End Sub
```


----------



## DanteAmor (Jan 4, 2023)

hwong8848 said:


> I have input some code to create boarder on my table, not sure this is the best way - hope you can let me know!!
> Furthermore, is there a way to sort the list by alphabetical order before pasting in the table?



Try this:


```
Sub Consol()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim st1 As Variant, st2 As Variant
  Dim i As Long, lr As Long, nRow As Long, lr1 As Long, lr2 As Long
  Dim c As Range, f As Range
 
  Set sh1 = ActiveSheet
  Set sh2 = Sheets("Consol")
 
  Set f = sh1.Range("E:E").Find("#", , xlValues, xlPart, xlByRows, xlPrevious)
  If Not f Is Nothing Then lr = f.Row - 1 Else lr = sh1.Range("E" & Rows.Count).End(3).Row
 
  st1 = Array("Initial Discussion", "Preparing Proposal", "Submitted / Waiting", "Contracting", "New Project", "Milestone", "Closing")
  st2 = Array("", "MIA", "LOST", "", "", "", "CLOSED")
 
  Application.ScreenUpdating = False
  sh2.Cells.Clear
  sh2.Range("B2").Resize(1, UBound(st1) + 1).Value = st1
  sh2.Range("J2").Resize(1, UBound(st2) + 1).Value = st2
   
  For Each c In sh1.Range("E2", sh1.Range("E" & Rows.Count).End(3))
    If c.Value <> "" Then
      Set f = sh2.Range("2:2").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        nRow = sh2.Cells(Rows.Count, f.Column).End(3).Row + 1
        sh2.Cells(nRow, f.Column).Value = c.Offset(, -1).Value
      End If
    End If
  Next
 
  Set f = sh2.Range("B:H").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr1 = f.Row + 2
  Set f = sh2.Range("J:P").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr2 = f.Row
 
  'sort the list
  For j = Columns("B").Column To Columns("P").Column
    If sh2.Cells(4, j).Value <> "" Then
      sh2.Range(sh2.Cells(2, j), sh2.Cells(lr1, j)).Sort key1:=sh2.Cells(2, j), _
        order1:=xlAscending, Header:=xlYes
    End If
  Next
 
  'Paste second block of data
  sh2.Range("J2:P" & lr2).Cut sh2.Range("B" & lr1)
 
  'Title format
  With sh2.Range("B2:H2")
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  With sh2.Range("B" & lr1 & ":H" & lr1)
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  With sh2.Range("B:H")
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With

  'Format with boarder
  sh2.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = xlContinuous

  Application.ScreenUpdating = True
End Sub
```


----------



## hwong8848 (Jan 5, 2023)

This definitely looks easier. 
Last question, I have edited some title so I extended the range.
Is there a way to color the column differently such as this? 





I have collected the RGB color I want:

B  247,213,241
C  218, 194, 236
D 189,215,238
E 198,224,180
F 248, 203, 173
G 255, 230, 153
H 217, 217, 217
I 166,166,166

I tried to do so using usedrange but it will color the title as well which I don't one..


```
Sub consolidate()
  Application.ScreenUpdating = False
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim st1 As Variant, st2 As Variant
  Dim i As Long, lr As Long, nRow As Long, lr1 As Long, lr2 As Long
  Dim c As Range, f As Range
 
  Set sh1 = ActiveSheet
  Set sh2 = Sheets("Pipeline")
 
  Set f = sh1.Range("E:E").Find("#", , xlValues, xlPart, xlByRows, xlPrevious)
  If Not f Is Nothing Then lr = f.Row - 1 Else lr = sh1.Range("E" & Rows.Count).End(3).Row
 
  st1 = Array("Initial Discussion", "Preparing Proposal", "Submitted / Waiting", "Contracting", "New Project", "Milestone", , "Sunsetting", "Closing")
  st2 = Array("", "MIA", "LOST", "", "", "", "CLOSED")
 

  sh2.Cells.Clear
  sh2.Range("B2").Resize(1, UBound(st1) + 1).Value = st1
  sh2.Range("K2").Resize(1, UBound(st2) + 1).Value = st2
   
  For Each c In sh1.Range("E2", sh1.Range("E" & Rows.Count).End(3))
    If c.Value <> "" Then
      Set f = sh2.Range("2:2").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        nRow = sh2.Cells(Rows.Count, f.Column).End(3).Row + 1
        sh2.Cells(nRow, f.Column).Value = c.Offset(, -1).Value
      End If
    End If
  Next
 
  Set f = sh2.Range("B:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr1 = f.Row + 2
  Set f = sh2.Range("K:R").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr2 = f.Row
 
  'sort the list
  For j = Columns("B").Column To Columns("R").Column
    If sh2.Cells(4, j).Value <> "" Then
      sh2.Range(sh2.Cells(2, j), sh2.Cells(lr1, j)).Sort key1:=sh2.Cells(2, j), _
        order1:=xlAscending, Header:=xlYes
    End If
  Next
 
  'Paste second block of data
  sh2.Range("K2:R" & lr2).Cut sh2.Range("B" & lr1)
 
  'Title format
  With sh2.Range("B2:I2")
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  With sh2.Range("B" & lr1 & ":I" & lr1)
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  With sh2.Range("B:I")
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With

  'Format with boarder
  sh2.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = xlContinuous
  
  'Format row height
  sh2.UsedRange.EntireRow.AutoFit
  
  Application.ScreenUpdating = True
End Sub
```


----------



## hwong8848 (Jan 5, 2023)

```
Sub consolidate()
  Application.ScreenUpdating = False
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim st1 As Variant, st2 As Variant
  Dim i As Long, lr As Long, nRow As Long, lr1 As Long, lr2 As Long
  Dim c As Range, f As Range
 
  Set sh1 = ActiveSheet
  Set sh2 = Sheets("Pipeline")
 
  Set f = sh1.Range("E:E").Find("#", , xlValues, xlPart, xlByRows, xlPrevious)
  If Not f Is Nothing Then lr = f.Row - 1 Else lr = sh1.Range("E" & Rows.Count).End(3).Row
 
  st1 = Array("Initial Discussion", "Preparing Proposal", "Submitted / Waiting", "Contracting", "New Project", "Milestone", "Sunsetting", "To Close")
  st2 = Array("", "MIA", "LOST", "", "", "", "CLOSED")
 

  sh2.Cells.Clear
  sh2.Range("B2").Resize(1, UBound(st1) + 1).Value = st1
  sh2.Range("K2").Resize(1, UBound(st2) + 1).Value = st2
   
  For Each c In sh1.Range("E2", sh1.Range("E" & Rows.Count).End(3))
    If c.Value <> "" Then
      Set f = sh2.Range("2:2").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        nRow = sh2.Cells(Rows.Count, f.Column).End(3).Row + 1
        sh2.Cells(nRow, f.Column).Value = c.Offset(, -1).Value
      End If
    End If
  Next
 
  Set f = sh2.Range("B:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr1 = f.Row + 2
  Set f = sh2.Range("K:R").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  lr2 = f.Row
 
  'sort the list
  For j = Columns("B").Column To Columns("R").Column
    If sh2.Cells(4, j).Value <> "" Then
      sh2.Range(sh2.Cells(2, j), sh2.Cells(lr1, j)).Sort key1:=sh2.Cells(2, j), _
        order1:=xlAscending, Header:=xlYes
    End If
  Next
 
  'Paste second block of data
  sh2.Range("K2:R" & lr2).Cut sh2.Range("B" & lr1)
  
  'Color Format
  With sh2.Range("B" & lr1)
    .Interior.Color = RGB(247, 213, 241)
  End With
    With sh2.Range("C" & lr1)
    .Interior.Color = RGB(218, 194, 236)
  End With
    With sh2.Range("D" & lr1)
    .Interior.Color = RGB(189, 215, 238)
  End With
    With sh2.Range("E" & lr1)
    .Interior.Color = RGB(198, 224, 180)
  End With
    With sh2.Range("F" & lr1)
    .Interior.Color = RGB(248, 203, 173)
  End With
    With sh2.Range("G" & lr1)
    .Interior.Color = RGB(255, 230, 153)
  End With
    With sh2.Range("H" & lr1)
    .Interior.Color = RGB(217, 217, 217)
  End With
      With sh2.Range("I" & lr1)
    .Interior.Color = RGB(166, 166, 166)
  End With
    
  'Title format
  With sh2.Range("B2:i2")
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With
  With sh2.Range("B" & lr1 & ":i" & lr1)
    .Interior.Color = vbBlack
    .Font.Color = vbWhite
  End With


  'Format with boarder
  sh2.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = xlContinuous
  
  'Format row height
  sh2.UsedRange.RowHeight = 50
  
  With sh2.Range("B:i")
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With
  
  Application.ScreenUpdating = True
End Sub
```

Felt like I misunderstood the code somewhere, but I input all the color in for now


----------



## hwong8848 (Jan 5, 2023)

```
Sub LastRowInOneColumn()
'Find the last used row in a Column: column A in this example
    Dim LastRow As Long
    Set sh2 = Sheets("Pipeline")
    With sh2
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        With sh2.Range("B2:B" & LastRow)
            .Interior.Color = RGB(247, 213, 241)
        End With
    End With
       With sh2
        LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row
        With sh2.Range("c2:c" & LastRow)
            .Interior.Color = RGB(218, 194, 236)
        End With
    End With
  
End Sub
```

I have create this code to highlight the cells range in different color, but it highlight blank cell and title as well, is there a way to skip those?


----------



## hwong8848 (Jan 5, 2023)

hwong8848 said:


> ```
> Sub LastRowInOneColumn()
> 'Find the last used row in a Column: column A in this example
> Dim LastRow As Long
> ...


I used a dumb way to color the column with different color and remove formatting for empty cell.


```
Sub FORMAT()

    Dim LastRow As Long, lr3 As Long, i As Long, c As Long
    Dim xcell As Range, xrange As Range
    Dim sh2 As Worksheet
    
    Set sh2 = Sheets("Pipeline")
    
    With sh2
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        With sh2.Range("B2:B" & LastRow)
            .Interior.Color = RGB(247, 213, 241)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row
        With sh2.Range("c2:c" & LastRow)
            .Interior.Color = RGB(218, 194, 236)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "d").End(xlUp).Row
        With sh2.Range("d2:d" & LastRow)
            .Interior.Color = RGB(189, 215, 238)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "e").End(xlUp).Row
        With sh2.Range("e2:e" & LastRow)
            .Interior.Color = RGB(198, 224, 180)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
        With sh2.Range("F2:F" & LastRow)
            .Interior.Color = RGB(248, 203, 173)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        With sh2.Range("G2:G" & LastRow)
            .Interior.Color = RGB(255, 230, 153)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
        With sh2.Range("H2:H" & LastRow)
            .Interior.Color = RGB(217, 217, 217)
        End With
    End With
    
    With sh2
        LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
        With sh2.Range("I2:I" & LastRow)
            .Interior.Color = RGB(166, 166, 166)
        End With
    End With
    
    lr3 = sh2.Cells.Find(What:="*", _
                    After:=Range("B1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
                    
    Set xrange = sh2.Range("B3:I" & lr3)
    
    For Each xcell In xrange
        If IsEmpty(xcell) Then
           xcell.Interior.Color = RGB(255, 255, 255)
        End If
        
    Next xcell
  
End Sub
```


----------

