Related
I have the issue with stacking in the loop
The macro should combine all columns (changeable number of rows) into one column.
Sub CombineColumns()
Dim xRng As Range
Dim i As Integer
Dim xLastRow As Integer
On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlDown).End(xlToRight))
xLastRow = xRng.Columns(1).Rows.Count + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(xRng.Columns(i).Rows.Count, i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = xLastRow + xRng.Columns(i).Rows.Count
Next
End Sub
Using Array is simple and fast.
Sub test()
Dim Ws As Worksheet, toWS As Worksheet
Dim vDB, vR()
Dim i As Long, j As Integer, n As Long
Set Ws = ActiveSheet
vDB = Ws.UsedRange
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 1 To r
For j = 1 To c
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, j)
Next j
Next i
Set toWS = Sheets.Add ' set toWs = Sheets(2) ~~> set your sheet
With toWS
.Cells.Clear
.Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End With
End Sub
If I got you right you want to do sth. like that
Option Explicit
Sub CombineColumns()
Dim xRng As Range
Dim i As Long
Dim xLastRow As Long
'On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlToRight))
xLastRow = lastRow(1) + 1
For i = 2 To xRng.Columns.Count
Range(xRng.Cells(1, i), xRng.Cells(lastRow(i), i)).Cut
ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
xLastRow = lastRow(1) + 1
Next
End Sub
Function lastRow(col As Long, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
The code still needs some improvement as it might loop over all columns espeically if there is no data.
This assumes on all your columns you have data on the 2nd row, to correctly identify the last column.
Option Explicit
Public Sub CombineColumns()
Dim LastColumn As Long, LastRow As Long, LastRowA As Long, i As Long, RngAddress As String
With ActiveSheet
' This assumes you have data on row 2 on all columns
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastColumn
' Get the last row of Col A on each iteration
LastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
' Get last row of the Col we're checking
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Get the used range address of the current Col
RngAddress = .Range(.Cells(1, i), Cells(LastRow, i)).Address
' Check if we have blank cells among the rows of the current Col
.Range(.Cells(1, i), Cells(LastRow, i)).Value2 = Evaluate("IF(NOT(ISBLANK(" & RngAddress & "))," & RngAddress & ")")
' Compress data (if there's no empty cells in the current Col the below line will give error, that's the role of err handling)
On Error Resume Next
.Range(.Cells(1, i), Cells(LastRow, i)).SpecialCells(xlCellTypeConstants, 4).Delete xlShiftUp
On Error GoTo 0
' Update the last row in case we compressed data
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
' Paste data in Col A
.Range(.Cells(1, i), Cells(LastRow, i)).Cut Destination:=.Range("A" & LastRowA)
Next i
Application.CutCopyMode = False
End With
End Sub
Maybe this could be a convenient solution for you :
Sub CombineColumns()
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Range("A2:A" & LastRow).Formula = "=B2 & C2 & D2 & E2 & F2 & G2 & H2" 'Insert here the columns you need to be combined
End Sub
Let me know if changes are necessary.
I want to find a range of same values in column A , and then calculate it average , can anyone help me ? below the code :
https://i.stack.imgur.com/bU1hW.png
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
Columns("A:A").Select
Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
'do it another thing
End If
End Sub
Thanks !
Solution 1
Try this
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
See image for reference.
Solution 2
Another easier approach will be to use formula. Enter the following formula in Cell E2
=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)
Drag/Copy down as required. Change range as per your data.
For details on AVERAGEIF see this.
EDIT : 1
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Dim dict As Object, c As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
c = aRng
For i = 1 To UBound(c, 1)
dict(c(i, 1)) = 1
Next i
.Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys) 'display uniques from column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
EDIT : 2 To get Min, instead of
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
use
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value
Use WorksheetFunction.AverageIf function, see code below :
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:A" & LastRow)
' average of values in column B of all cells in column A = 1
Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))
' average of values in column B of all cells in column A = 2
Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With
End Sub
This is using a variant array method. Try this.
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim vDB, vR(), rngDB, vResult()
Dim r As Integer, n As Long, j As Long, i As Integer
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
rngDB = .Range("a1", "b" & LastRow)
vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vResult(1 To r)
For i = 1 To r
n = 0
For j = 1 To LastRow
If vDB(i, 1) = rngDB(j, 1) Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = rngDB(j, 2)
End If
Next j
vResult(i) = WorksheetFunction.Average(vR)
Next i
.Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
End With
End Sub
To use the .Find Function
Find the values in column A excluding duplicates
Use the unique values on the Find Function
When the value is found, sum the value in column B and on a counter
Divide the sum value by the counter to obtain the average value
Dim ws As Worksheet
Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
Set ws = ThisWorkbook.Sheets(1)
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
For i = 2 To lastrow
Set c = ws.Cells(i, 1)
Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
x = Application.WorksheetFunction.CountIf(rngloop, c)
If x = 1 Then
'Debug.Print c 'Values in column A without duplicates
'Work with the values found
With rng
Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
If Not cellFound Is Nothing Then
FirstAddress = cellFound.Address
Do
SumValues = ws.Cells(cellFound.Row, 2) + SumValues
k = k + 1
Set cellFound = .FindNext(cellFound)
Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
AverageValues = SumValues / k
Debug.Print "Value: " & c & " Average: " & AverageValues
End If
End With
End If
k = 0
SumValues = 0
Next i
Note that the use of .Find is slower than CreateObject("Scripting.Dictionary"), so for large Spreadsheets the code of #Mrig is optimized
Please try this code:
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
'if found more than one value
'do it another thing
sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
Else
'do it another thing
End If
Next i
End Sub
Hope this help.
I am trying to join cells in a row if a value exists in a cell in that row.
The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4 columns.
The cells cant be merged as the data will only be kept from the first cell.
The only words which are always constant are "contain" and "for" in column B.
What I've tried resembles this:
If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.
thanks, in advance, for any help.
Edit Here is the code:
Sub Joining()
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
With Activesheet
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "B").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
.Cells(z, "B").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Not sure if this is exactly what you want but it will get you close:
Sub summary()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
Set sh1 = ActiveSheet
With ActiveWorkbook
Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
With sh1
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "A").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
sh2.Cells(z, "A").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).
It works although I'm sure there is a much simpler way of creating it.
Maybe someone can have a go at cleaning it up?
Sub SelRows()
Dim ocell As Range
Dim rng As Range
Dim r2 As Range
For Each ocell In Range("B1:B1000")
If ocell.Value Like "*contain*" Then
Set r2 = Intersect(ocell.EntireRow, Columns("A:G"))
If rng Is Nothing Then
Set rng = Intersect(ocell.EntireRow, Columns("A:G"))
Else
Set rng = Union(rng, r2)
End If
End If
Next
Call JoinAndMerge
If Not rng Is Nothing Then rng.Select
Set rng = Nothing
Set ocell = Nothing
End Sub
Private Sub JoinAndMerge()
Dim outputText As String, Rw As Range, cell As Range
delim = " "
Application.ScreenUpdating = False
For Each Rw In Selection.Rows
For Each cell In Rw.Cells
outputText = outputText & cell.Value & delim
Next cell
With Rw
.Clear
.Cells(1).Value = outputText
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
outputText = ""
Next Rw
Application.ScreenUpdating = True
End Sub
I have created macro that works like a vlookup but has split values. I would like to find value from second sheet of split values (separated by semicolon ) and copy and paste the description to new sheet.
The first loop goes through the list in sheet 2 and sets the value in a variable, the second loop through split values checks when there is exact match and the description is copied and pasted to the second sheet.
However - it doesn't work and I don't know what the problem is.
I have notification "type mismatch".
I tried vlookup with part text string but it doesn't work either.
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr = variable Then
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
Next i
Else
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
End If
End If
Next
End If
Next
End With
End Sub
I changed my code but it is still not work properly, I have a result:
try this
Sub test()
Dim Cl As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
With Sheets("Sheet1")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
If Cl.Value <> "" Then
Dic.Add Cl.Row & "|" & Replace(LCase(Cl.Value), ";", "||") & "|", Cl.Offset(, 1).Text
End If
Next Cl
End With
With Sheets("Sheet2")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each Key In Dic
If Key Like "*|" & LCase(Cl.Value) & "|*" And Cl.Value <> "" Then
Cl.Offset(, 1).Value = Dic(Key)
Exit For
End If
Next Key
Next Cl
End With
End Sub
Output Result
Sub YourVLookup()
Dim rng As Variant, rng2 As Variant
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim aCell As Variant, bCell As Variant
Dim myAr() As String, variable As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow)
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow)
For i = LBound(rng2, 1) To UBound(rng2, 1)
If Len(Trim(rng2(i, 1))) <> 0 Then
variable = rng2(i, 1)
For j = LBound(rng, 1) To UBound(rng, 1)
If Len(Trim(rng(j, 1))) <> 0 Then
If InStr(1, rng(j, 1), ";") > 0 Then
myAr = Split(rng(j, 1))
For k = LBound(myAr) To UBound(myAr)
If myAr(k) = variable Then
rng2(i, 2) = myAr(k)
End If
Next k
ElseIf rng(j, 1) = rng2(i, 1) Then
rng2(i, 2) = rng(j, 2)
End If
End if
Next j
End If
Next i
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow) = rng
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow) = rng2
End Sub
You were pasting something that you don't have copied already, you forgot to close a With, and you can't use bCell(,2), so
Try this :
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr() As String
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
End With
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr(i) <> variable Then
Else
'You were pasting nothing with that
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
Next i
Else
'Same here
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
End If
Next aCell
End If
Next bCell
End With
End Sub
Sub Match()
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long, bln As Boolean, rng1 As Range, rng2 As Range, i As Long, j As Long
If Not IsEmpty(rng1) Then
For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Sheet1").Range("A" & i)
For j = 1 To Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Sheet1").Range("C" & j)
bln = False
var = Application.Match(rng1.Value, rng2, 0)
If Not IsError(var) Then
bln = True
Exit For
Exit For
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Sheet1").Range("A" & i)
If bln = False Then
Cells(rng1).Font.Bold = False
Else
Cells(rng1).Font.Bold = True
End If
Next i
End If
Application.ScreenUpdating = True
End Sub
Sub CompareAndHighlight()
Dim rng1 As Range, rng2 As Range, i As Long, j As Long
For i = 1 To Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("sheet1").Range("C" & i)
For j = 1 To Sheets("sheet2").Range("C" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("sheet2").Range("C" & j)
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
rng1.Interior.Color = RGB(255, 255, 0)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
I am trying to compare the data column A with the data in column C
However the challenge is , If there is a match I will then need to move the cell from column C to column B on the corresponding row.
Unfortunately I can not post pictures yet, I hope this is clear enough for someone to support me with?
I have improvised to use the "code snippet to display how the data should look assuming they are arranged in Columns A B and C
Before
A12334 A12352
A12335 A12353
A12336 A12339
A12337 A12340
A12338 A12341
A12339 A12354
A12340 A12355
A12341 A12356
A12342 A22354
A12343 A22356
A12344 A22358
A12345 A22360
A12346 A22362
A12347 A22364
A12348 A22366
A12349 A22368
A12350 A22370
A12351 A22372
A12352 A12357
A12353 A12358
A12354 A12334
A12355 A12335
A12356 A12336
A12357 A12337
A12358 A12338
A12359 A22370
A12360 A22372
A12361 A12361
After:
A12334 A12334
A12335 A12335
A12336 A12336
A12337 A12337
A12338 A12338
A12339 A12339
A12340 A12340
A12341 A12341
A12342 A22354
A12343 A22356
A12344 A22358
A12345 A22360
A12346 A22362
A12347 A22364
A12348 A22366
A12349 A22368
A12350 A22370
A12351 A22372
A12352 A12352
A12353 A12353
A12354 A12354
A12355 A12355
A12356 A12356
A12357 A12357
A12358 A12358
A12359 A22370
A12360 A22372
A12361 A12361
Try this to get to your original need: (Not sure what your sheet names are so you might need to edit to reflect correct sheet.)
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, Chk As Range, LastDest As Long
Set ws1 = Sheets("Sheet1")
iL = ws1.Range("A" & Rows.Count).End(xlUp).Row
For j = 3 To 5
Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
For i = 2 To iL
Set rng1 = ws1.Range("A" & i)
Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not var Is Nothing Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).PasteSpecial
End If
Next i
ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Copy
LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet2").Cells(LastDest, 1).PasteSpecial xlPasteValues
LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Set rng3 = Sheets("Sheet2").Range("A2:A" & LastDest)
For each Chk in rng3
If Len(Chk.Value) = 0 Then
Chk.EntireRow.Delete xlShiftUp
End If
Next Chk
ws1.Range("B:B").Clear
Next j
End Sub
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Variant
iL = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To iL
Set rng1 = Sheets("Sheet1").Range("A" & i)
Set rng2 = Sheets("Sheet1").Range("C:C")
var = Application.Match(rng1.Value, rng2, 1)
If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then
bln = True
If bln = True Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).PasteSpecial
End If
Set rng1 = Nothing
Set rng2 = Nothing
End If
Next i
End Sub
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, rng3 As Range, rng4 As Range, lRows As Long, lRows2 As Long, jL
Set ws1 = Sheets("Comparison Sheet")
Set ws2 = Sheets("Comparison Sheet Final")
iL = ws1.Range("A" & Rows.Count).End(xlUp).Row
jL = ws1.Cells(2, Columns.Count).End(xlToLeft).Column
For j = 3 To jL
Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
For i = 2 To iL
Set rng1 = ws1.Range("A" & i)
Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not var Is Nothing Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Offset(0, 1).Font.Name = "Wingdings"
rng1.Offset(0, 1).Value = ChrW(&HFC)
End If
Next i
ws1.Cells(2, 2) = ws1.Cells(2, j)
lRows = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Set rng3 = ws1.Range(ws1.Cells(2, 2), ws1.Cells(lRows, 2))
lRows2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
lCols = j - 1
Set rng4 = ws2.Range(ws2.Cells(2, lCols), ws2.Cells(lRows, lCols))
rng4.Font.Name = "Wingdings"
rng4.Value = rng3.Value
rng3.ClearContents
ws2.Rows(2).Font.Name = "Calibri"
Next j
End Sub
How it currently looks with your code with slight edits