VBA to consolidate list

[hwong8848]

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.xlsx
	A	B	C	D	E
15		BEA	Non-executive Benchmarking & STI review	BEA Non-executive Benchmarking & STI review	LOST
16		COSCO Shipping	Investment team pay structure	COSCO SHIPPING Investment team pay structure	Closing
17		HKICL	Pay Trend	HKICL Pay Trend	Preparing Proposal
18		HKLand	Job Matching+Pay Benchmarking	HKLAND Job Matching+Pay Benchmarking	CLOSED
19		HKMA	Pay trend	HKMA Pay trend	Milestone
20		HKMC		HKMC	CLOSED
21		HKTDC	pay level review	HKTDC pay level review	Preparing Proposal
22		MPFA	Pay review + rating distribution	MPFA Pay review + rating distribution	Closing
23		PGS	JE + pay range	PGS JE + pay range	MIA
24		Swire Properties	grading, pay and benefits	SWIRE PROPERTIES grading, pay and benefits	Milestone
25
26		AIA	RemCo Advisory	AIA RemCo Advisory	Submitted / Waiting
27		AXA	APAC team for a Paris project	AXA APAC team for a Paris project	New Project
28		Bank of China HK	Pay Assessment for Top Management	BANK OF CHINA HK Pay Assessment for Top Management	LOST
29		Best Assistant	Pre-IPO support	BEST ASSISTANT Pre-IPO support	Preparing Proposal
30		Chen Hsong	RemCo meeting support	CHEN HSONG RemCo meeting support	Submitted / Waiting
31		China State Construction Engineering	Incentive/ retention program	CHINA STATE CONSTRUCTION ENGINEERING Incentive/ retention program	CLOSED
32		COSCO Shipping	LTI	COSCO SHIPPING LTI	LOST
33		Hysan Development	LTI design	HYSAN DEVELOPMENT LTI design	MIA
34		Maxim	Pay philosophy workshop	MAXIM Pay philosophy workshop	Closing
35		Peak Re	EC Benchmarking	PEAK RE EC Benchmarking	New Project
36		Phase Scientific	LTI Project	PHASE SCIENTIFIC LTI Project	Closing
37		Prudential plc	EC Benchmarking	PRUDENTIAL PLC EC Benchmarking	Closing
38		Prudential plc	RemCo Advisory	PRUDENTIAL PLC RemCo Advisory	LOST
39		QCP	Executive benchmark and incentive	QCP Executive benchmark and incentive	Submitted / Waiting
40		RPDA	2022 data collection	RPDA 2022 data collection	Preparing Proposal
41		Shui On Land	Exec benchmark and LTI design	SHUI ON LAND Exec benchmark and LTI design	Submitted / Waiting
42		SOCAM	LTI design work	SOCAM LTI design work	Contracting
43		StarHub	Total comp review	STARHUB Total comp review	Milestone
44		Swiss Re	EC Benchmarking	SWISS RE EC Benchmarking	LOST
45
46		BEA (Bank of East Asia)	EES	BEA (BANK OF EAST ASIA) EES	New Project
47		CCBA	EES - Internal Support Services	CCBA EES - Internal Support Services	LOST
48		CMHK	EES	CMHK EES	Submitted / Waiting
49		DFS	Comms Support on Rewards Offering	DFS Comms Support on Rewards Offering	CLOSED
50		Eaton HK	EES license	EATON HK EES license	Closing
51		Huatai Financial Holdings	EES License + VFG	HUATAI FINANCIAL HOLDINGS EES License + VFG	CLOSED
52		Langham Hotel Group	EES	LANGHAM HOTEL GROUP EES	Closing
53		Mandarin Oriential Hotel Group	EES	MANDARIN ORIENTIAL HOTEL GROUP EES	Initial Discussion
54		PGS	Leadership development	PGS Leadership development	Contracting
55		Vitasoy	EES	VITASOY EES	Preparing Proposal
56
57		AIA	benchmarking of IA positions	AIA benchmarking of IA positions	Initial Discussion
58		ALDI Asia Limited	Survey+focus group	ALDI ASIA LIMITED Survey+focus group	Preparing Proposal
59		AnimocaBrands	Job levelling	ANIMOCABRANDS Job levelling	Submitted / Waiting
60		ASM	grading structure validation	ASM grading structure validation	Preparing Proposal
61		Aurecon	pay competitive analysis & STI review	AURECON pay competitive analysis & STI review	Preparing Proposal
62		Automated Systems Limited	EES	AUTOMATED SYSTEMS LIMITED EES	MIA
63		BDX	EES	BDX EES	New Project
64		CCBA	Saville assessment	CCBA Saville assessment	Submitted / Waiting
65		China Harbour Eng HK	Grading structure, perf mgmt, comp review	CHINA HARBOUR ENG HK Grading structure, perf mgmt, comp review	Preparing Proposal
66		China Investment Holdings Limited		CHINA INVESTMENT HOLDINGS LIMITED	Preparing Proposal
67		China Resources Capital	Investment team setup	CHINA RESOURCES CAPITAL Investment team setup	Submitted / Waiting
68		CityU VMC	EES	CITYU VMC EES	Submitted / Waiting
69		CLP	EES	CLP EES	MIA
70		Cyberport	pay benefit	CYBERPORT pay benefit	Preparing Proposal
71		ESF	Int'l School	ESF Int'l School	Contracting
72		Fusion Bank	LTI Plan Design	FUSION BANK LTI Plan Design	CLOSED
73		GDS	TBC	GDS TBC	CLOSED
74		GEG	Employee Experience Strategy and Listening Approach	GEG Employee Experience Strategy and Listening Approach	Submitted / Waiting
75		Global Glory	Total comp strategy design	GLOBAL GLORY Total comp strategy design	New Project
76		Harrow	Sponsor survey	HARROW Sponsor survey	New Project
77		HK Electric	pay benchmarking	HK ELECTRIC pay benchmarking	Contracting
78		HKJC	Pay + STI	HKJC Pay + STI	Closing
79		HKSTP	PHASE 2: Pay philosophy & Grading	HKSTP PHASE 2: Pay philosophy & Grading	CLOSED
80		HKSTP	Investment team pay structure	HKSTP Investment team pay structure	Submitted / Waiting
81		HSBC	Survey	HSBC Survey	Milestone
82		Hysan Development	LTI design	HYSAN DEVELOPMENT LTI design	Preparing Proposal
83		IQAX (OOCL)	Pay benchmarking for IT jobs	IQAX (OOCL) Pay benchmarking for IT jobs	Closing
84		KMB	Pay Review	KMB Pay Review	Submitted / Waiting
85		LCSD	Job Pricing	LCSD Job Pricing	New Project
86		Lee Kam Kee	EES	LEE KAM KEE EES	Submitted / Waiting
87		Maxim's	EES	MAXIM'S EES	LOST
88		Meiyume	Rewards Strategy	MEIYUME Rewards Strategy	Preparing Proposal
89		Paul Y Engineering	EES	PAUL Y ENGINEERING EES	MIA
90		Prenetics	Job pricing	PRENETICS Job pricing	LOST
91		Qatar Investment Authority	STI & Incentive design	QATAR INVESTMENT AUTHORITY STI & Incentive design	Preparing Proposal
92		Sompo	job matching	SOMPO job matching	Submitted / Waiting
93		Swire Properties	EES	SWIRE PROPERTIES EES	Contracting
94		Taishin (TW)	Pulse	TAISHIN (TW) Pulse	Closing
95		Vingroup	LTI design	VINGROUP LTI design	Milestone
96		YWCA	Saville assessment	YWCA Saville assessment	Preparing Proposal
97	#	#	#	#	#
98	INTERNAL STUFF
99		x		x
100		x	x	x	x
101		x
102		x		x	x
103		x	xx
104
Jan 16

Cell Formulas
Range	Formula
D15:D24,D57:D96,D46:D55,D26:D44	D15	=UPPER(B15)&" "&C15

Cells with Data Validation
Cell	Allow	Criteria
E15:E24	List	=MISC!$A$2:$A$11
E57:E96	List	=MISC!$A$2:$A$11
E46:E55	List	=MISC!$A$2:$A$11
E26:E44	List	=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.xlsx
	B	C	D	E	F	G	H
2	Initial Discussion	Preparing Proposal	Submitted / Waiting	Contracting	New Project	Milestone	Closing
3					COSCO SHIPPING Investment team pay structure	CHINA STATE CONSTRUCTION ENGINEERING Incentive/ retention program	BEA Non-executive Benchmarking & STI review
4							HKICL Pay Trend
5
6
7
8
9
10
11
12
13
14
15		MIA	LOST				CLOSED
16
17
18
19
20
21
22
Consol

Much Appreciated!

 

[DanteAmor]

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]

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]

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]

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]

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]

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]

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?

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