Thread: Matching cells
View Single Post
  #31   Report Post  
Posted to microsoft.public.excel.programming
GS[_2_] GS[_2_] is offline
external usenet poster
 
Posts: 3,514
Default Matching cells

Since the macro didn't work, I thought I'd try to see it someone had
an other way.


The macro didn't work because you ran it on a sheet with different
column layouts than the sample sheet you sent me!

I have revised the macro to be more easily adaptable to different
column layouts. All that's required is to revise the section addresses
to match whatever sheet you want to run the macro on.

Revised code:

Sub FindMatches()
' Finds matching values in 2 sections of data on the same wks.
' Loops Section1,Column1 searching for matches in Section2,Column1.
' Puts found matches in same row on new sheet.

'Section addresses. (change/add as desired)
Const sRngSection1 As String = "$A$1:$N$1"
Const sRngSection2 As String = "$O$1:$AC$1"

Dim wksSource As Worksheet, wksTarget As Worksheet
Dim vVal As Variant, vCalcMode As Variant, rng As Range
Dim lSection1_NumCols As Long, lSection2_NumCols As Long
Dim lSection1_NumRows As Long, lSection2_NumRows As Long
Dim lNextRow As Long, i As Long

Set wksSource = ActiveWorkbook.ActiveSheet
Set wksTarget = ActiveWorkbook.Sheets.Add(After:=ActiveSheet)
wksTarget.Name = wksSource.Name & "_2"

With Application
.ScreenUpdating = False
vCalcMode = .Calculation
.Calculation = xlCalculationManual
End With 'Application

With wksSource
lSection1_NumCols = .Range(sRngSection1).Columns.Count
lSection2_NumCols = .Range(sRngSection2).Columns.Count
lSection1_NumRows = .Range(sRngSection1).Cells(1,
1).End(xlDown).Row
' lSection2_NumRows =
..Range(sRngSection1).Cells(1,1).End(xlDown).Row

For i = 1 To lSection1_NumRows
vVal = .Cells(i, 1).Value
If vVal < "" Then
Set rng = .Range("$O:$O").Find(what:=vVal)
If Not rng Is Nothing Then '//we have a match
lNextRow = lNextRow + 1
Application.StatusBar = "Processing match #" & lNextRow
.Cells(i, 1).Resize(1, lSection1_NumCols).Copy _
Destination:=wksTarget.Cells(lNextRow, 1)
rng.Resize(1, lSection2_NumCols).Copy _
Destination:=wksTarget.Cells(lNextRow, lSection1_NumCols
+ 1)
End If 'Not rng Is Nothing
End If 'vVal < ""
Next
End With 'wksSource

'Cleanup...
With wksTarget
.UsedRange.EntireColumn.AutoFit: .Activate
End With 'wksTarget

With Application
.ScreenUpdating = True: .Calculation = vCalcMode: .StatusBar = ""
End With 'Application
End Sub

BTW, this works on BOTH samples you sent me.

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc