Matching cells

[GS]

gcotterl wrote :

It looks like I have no other option than to MANUALLY move each cell
in Col A so it lines up with the matching cell in the Col B.

No, you won't have to do that. I'm working on code to put all matches
on a new sheet but I've been interupted by a meeting. I'll resume later
on and post the code for you to copy into a standard module.

 

[GS]

Here's what works for me. It takes a while to go through each cell in
colA, but takes less than a minute to process all 18513 entries.

Sub FindMatches()
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim vVal As Variant, rng As Range
Dim lSect1Cols As Long, lSect2Cols As Long
Dim lSect1Rows As Long, lSect2Rows As Long
Dim lNextRow As Long, i As Long

'Hide screen activity
Application.ScreenUpdating = False

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

With wksSource
lSect1Cols = .Range("$A$1:$N$1").Columns.Count
lSect2Cols = .Range("$O$1:$AC$1").Columns.Count
lSect1Rows = .Range("$A$1").End(xlDown).Row
' lSect2Rows = .Range("$O$1").End(xlDown).Row

For i = 1 To lSect1Rows
vVal = .Cells(i, 1).Value
Set rng = .Range("$O:$O").Find(what:=vVal)
If Not rng Is Nothing Then '//we have a match
Application.StatusBar = "Found match for " & vVal
lNextRow = lNextRow + 1
.Cells(i, 1).Resize(1, lSect1Cols).Copy _
Destination:=wksTarget.Cells(lNextRow, 1)
rng.Resize(1, lSect2Cols).Copy _
Destination:=wksTarget.Cells(lNextRow, lSect1Cols + 1)
End If
Next
End With
With wksTarget
.UsedRange.EntireColumn.AutoFit: .Activate
End With
Application.StatusBar = "" '//reset
End Sub

 

[gcotterl]

Here's what works for me. It takes a while to go through each cell in
colA, but takes less than a minute to process all 18513 entries.

Sub FindMatches()
  Dim wksSource As Worksheet, wksTarget As Worksheet
  Dim vVal As Variant, rng As Range
  Dim lSect1Cols As Long, lSect2Cols As Long
  Dim lSect1Rows As Long, lSect2Rows As Long
  Dim lNextRow As Long, i As Long

  'Hide screen activity
  Application.ScreenUpdating = False

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

  With wksSource
    lSect1Cols = .Range("$A$1:$N$1").Columns.Count
    lSect2Cols = .Range("$O$1:$AC$1").Columns.Count
    lSect1Rows = .Range("$A$1").End(xlDown).Row
'    lSect2Rows = .Range("$O$1").End(xlDown).Row

    For i = 1 To lSect1Rows
      vVal = .Cells(i, 1).Value
      Set rng = .Range("$O:$O").Find(what:=vVal)
      If Not rng Is Nothing Then '//we have a match
        Application.StatusBar = "Found match for " & vVal
        lNextRow = lNextRow + 1
        .Cells(i, 1).Resize(1, lSect1Cols).Copy _
            Destination:=wksTarget.Cells(lNextRow, 1)
        rng.Resize(1, lSect2Cols).Copy _
            Destination:=wksTarget.Cells(lNextRow, lSect1Cols + 1)
      End If
    Next
  End With
  With wksTarget
    .UsedRange.EntireColumn.AutoFit: .Activate
  End With
  Application.StatusBar = "" '//reset
End Sub

--
Garry

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

I ran your Macro but there are no results (my spreadsheet is empty).

 

[GS]

gcotterl formulated on Sunday :

I ran your Macro but there are no results (my spreadsheet is empty).

Was the sheet with the lists the active sheet? When I ran it in your
wkb, it generated Sheets("MULTI_2") with 1483 rows of data.

 

[gcotterl]

gcotterl formulated on Sunday :







Was the sheet with the lists the active sheet? When I ran it in your
wkb, it generated Sheets("MULTI_2") with 1483 rows of data.

--
Garry

Free usenet access athttp://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc- Hide quoted text -

- Show quoted text -

Yes, the sheet with the lists was the active sheet.

I must be doing something wrong.
(I wasted all afternoon on this; it's most frustrating!!!!)

Can I re-send my spreadsheet to you so you can run your macro on it
and send the results back to me?

 

[GS]

Yes, resend!

 

[Jim Cone]

Garry,
I just awoke to the fact the same request is posted on public.excel.misc
by "Gary" under the title "Eliminate non-matching cells.
--
Jim Cone
Portland, Oregon USA
http://www.mediafire.com/PrimitiveSoftware
(Lottery Numbers.xls - in the free folder)




"GS" <[email protected]>
wrote in message
news:[email protected]...

 

[gcotterl]

Garry,
I just awoke to the fact the same request is posted on public.excel.misc
by "Gary" under the title "Eliminate non-matching cells.
--
Jim Cone
Portland, Oregon USAhttp://www.mediafire.com/PrimitiveSoftware
(Lottery Numbers.xls - in the free folder)

"GS" <[email protected]>
wrote in message



- Show quoted text -

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

 

[GS]

Jim Cone wrote :

Garry,
I just awoke to the fact the same request is posted on public.excel.misc
by "Gary" under the title "Eliminate non-matching cells.
--
Jim Cone
Portland, Oregon USA
http://www.mediafire.com/PrimitiveSoftware
(Lottery Numbers.xls - in the free folder)

Jim,
You just awoke me to the fact that I was not subscribed to that group!
I am now!<g>

Yes, the OP's name is Gary. Unfortunately, he has difficulty explaining
what he wants in terms we understand (ie: Excel lingo), and so it takes
an awful lot of back&forth (as you can see) to get to where we can help
him. He seems to be working at getting better at how to express this. I
think it depends, really, on if he can decide what details we need to
know in order to best help him.

In time.., all in good time!<g>

 

[GS]

Gary,
The code was designed to work on the original file you sent me. I'll
return it to you with the results of running the code on
Sheets("MULTI").

 

[GS]

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.

 

[GS]

By the way, I'm using Microsoft Office Excel 2007.

I know that. What's your point?

 

[GS]

GS formulated the question :

Set rng = .Range("$O:$O").Find(what:=vVal)

Change the above line (in the loop) to:

Set rng = .Range(sRngSection2).EntireColumn.Find(what:=vVal)

...so it doesn't need to be revised to suit.

 

[GS]

GS explained :

GS formulated the question :

Change the above line (in the loop) to:

Set rng = .Range(sRngSection2).EntireColumn.Find(what:=vVal)

..so it doesn't need to be revised to suit.

Actually, that's way too slow so revise further as follows...

Set rng = .Range(sRngSection2).Cells(1).EntireColumn.Find(what:=vVal)