PDA

View Full Version : Solved: SIMILAR NUMBERS



oleg_v
05-16-2010, 03:34 AM
Hi
I need some Help With a macro.

I need a macro to find 3 similar numbers in column "AB"starting with "AB10 till AB20" than copy the rows that belongs to those numbers to sheet2 starting at "C3"

Thanks

Oleg

oleg_v
05-16-2010, 04:00 AM
hi
here is some code that i am working with

Public Sub COPYDT()
Const TEST_COLUMN As String = "Ab" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long, NextRow2 As Long
Dim row As Long
NextRow = 1
ROW2 = 6

row = 6
With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).row
'For i = 7 To LastRow
h:
row = 6
row = row + 1
ROW2 = ROW2 + 1

myvar = Sheets("sheet1").Cells(ROW2, 28).Value
If ROW2 = 15 Then
Exit Sub
End If




myvar2 = Sheets("sheet1").Cells(row, 28).Value


If myvar = myvar2 Then

NextRow = NextRow + 1

.Cells(i, "b").Resize(, 27).Copy Worksheets("Sheet2").Cells(NextRow, "d")
onemore1:
NextRow2 = NextRow + 1

.Cells(i, "b").Resize(, 27).Copy Worksheets("Sheet2").Cells(NextRow2, "d")
onemore:

row = row + 1


myvar2 = Sheets("sheet1").Cells(row, 28).Value

If myvar = myvar2 Then
GoTo onemore1



End If

p:
'Next i
GoTo h
End With

End Sub

mdmackillop
05-16-2010, 04:04 AM
Apologies, I totally misread your question. Previous misleading suggestion deleted!

mdmackillop
05-16-2010, 04:14 AM
You'll need to adjust the data you wish to copy


Sub Test()
Dim Rng As Range
Dim cel As Range
Dim tgt As Range
Dim i As Long
Set tgt = Sheets(2).Range("C3")
Set Rng = Range("AB10:AB20")
For Each cel In Rng
If Application.CountIf(Rng, cel) = 3 Then
cel.Resize(, 10).Copy tgt.Offset(i)
i = i + 1
End If
Next
End Sub

Bob Phillips
05-16-2010, 04:14 AM
What does similar mean? They went to the same school, same gender?

oleg_v
05-16-2010, 04:19 AM
similar mean "same data in the cell"

i am sorry for my English

oleg_v
05-16-2010, 04:29 AM
You'll need to adjust the data you wish to copy


Sub Test()
Dim Rng As Range
Dim cel As Range
Dim tgt As Range
Dim i As Long
Set tgt = Sheets(2).Range("C3")
Set Rng = Range("AB10:AB20")
For Each cel In Rng
If Application.CountIf(Rng, cel) = 3 Then
cel.Resize(, 10).Copy tgt.Offset(i)
i = i + 1
End If
Next
End Sub



i can not get it to work

mdmackillop
05-16-2010, 04:53 AM
Please post some sample data. I can't test it otherwise

oleg_v
05-16-2010, 04:57 AM
attached sample

mdmackillop
05-16-2010, 05:55 AM
Correct the target sheet and range to be copied to suit your needs.

oleg_v
05-16-2010, 08:42 PM
hi
the macro is working but it does not what asked
i do not complitly understand but what i need is to find similar numbers in column "ab" the to copy the rows that belongs to those numbers meaning if the similar numbers are in "ab11" and "ab20" then copy the rows 11 and 20

thanks

Blade Hunter
05-16-2010, 10:59 PM
Change this:


Set tgt = Sheets(2).Range("C3")


to

Set tgt = Sheets(2).Range("A3")


and


cel.Resize(, 10).Copy tgt.Offset(i)


to this

cel.row.Copy
tgt.Offset(i).paste

oleg_v
05-16-2010, 11:43 PM
hi
this works great
i wanted to ask
why when the rows are being copied the similar rows does not goes one after anther
i sow this when i used this macro to a sheet with 1000 filled rows

Aussiebear
05-18-2010, 10:44 PM
You need to create a loop function.

BTW before you ask how, I need to see that you are making an effort to learn VBA here. So here's your challange, Search the Internet about creating a looping function and post the relevant code back here, then we'll offer you any further assistance if required. To this point in time, we continually provide you with assistance you hardly ever provide any code with yours questions to show that you as an individual are attempting to learn anything.

oleg_v
05-22-2010, 09:17 PM
hi
i am learning the vba and i have created a loop function and put it in the code
a simplest loop function with a counting numbers and a ''go to" command to a desired label

but i8 can not get the similar data to go one after anther.

oleg_v
05-22-2010, 09:22 PM
Sub Find()
Dim Found As Range, It
Dim k As Long, t

k = 0
t = 0


y = Sheets("sheet1").Range("q65536").End(xlUp).row
one:
k = k + 1
t = t + 1
myvar = Worksheets("Sheet1").Range("q" & (y - t)).Value
It = myvar 'InputBox("Enter search term")
Set Found = Columns("q").Find(what:=It, LookIn:=xlValues, lookat:=xlWhole)
If Not Found Is Nothing Then
MsgBox It & " found in " & Found.Address(False, False), vbInformation
Else
MsgBox It & " not found.", vbExclamation
End If
Range(Found.Address(False, False)).Select
MsgBox k

Selection.Interior.ColorIndex = k

If t < y Then
GoTo one
Else
Exit Sub
End If


End Sub

mdmackillop
05-23-2010, 04:11 AM
Try to avoid GoTo in creating Loops, use one of the inbuilt methods, Do Until....Loop, For Each...Next etc.
For a Find Loop, there is a good example in VBA Help. Understand what it is doing, as you will use it many times.



'Example
'This example finds all cells in the range A1:A500 that contain the value 2 and
'changes their values to 5.

With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

GTO
05-23-2010, 06:02 AM
Oleg,

Unfortunately, it is off to bed in a bit for this lad, but I kesp staring at this, and it seems to me that we need to take a step back - maybe several steps...

In post #1 and #2, you discuss wanting to copy rows, where we find "3 similar numbers" in Col AB.

In post #17 you offer totally different code that colors a cell in Col Q.

YACK!

The code in the wb at #9 appears (not well checked) to match the code at #2. It fails to compile, as there's a missing End If. Guessing at where to put that in, results in a runtime failure, as with the 'For i = ...' rem'd out, '.Cells(i, "b").... fails, as we're now trying to refer to row zero. This of course results in Excel giving up, which seemed like a good idea to me too...

So... I would respectfully suggest that you may wish to try and describe again what it is we are trying to do.

I am going to guess that your latest code has to do with another bit of the project.

Further - as to the, find 3 similar numbers in column "AB"starting with "AB10 till AB20" than copy the rows that belongs to those numbers to sheet2 starting at "C3"

I am not sure why you are saying to start at row 10, as at least visually, it would seem to start at row 11. Please confirm or correct.

Further - by three similar numbers, might you (from the wb attached @ #9) be referring to the three numbers (2, 3, 5) that have duplicates?

Not sure that his will help, or that I am on course, but hope so,

Mark

oleg_v
05-23-2010, 06:18 AM
HI

i am sorry for so many changes but i nearly finish with my project and tomorrow
i will post sample file with a working code

thank you for your notes in the future i will try to be more focused

GTO
05-23-2010, 06:26 AM
@Malcom:

Hi Brother,


...there is a good example in VBA Help...

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress


IMO, I do not think that the help example is all that slick. I use it every so often myself, just because of blonde memory and an easy copy paste, but only because the error is usually not a worry. That said, if 'c' actually becomes Nothing (as it will here after replacing the last '2' with a '5'), then the Loop While... test fails, as of course the c.Address (or Nothing.Address) goes kaboom.

Have a great day :-)

Mark

oleg_v
05-23-2010, 06:28 AM
I done with this project please see attached file

you opinion will be very appreciated!!!

thanks

mdmackillop
05-23-2010, 07:38 AM
Thanks Mark,
I'd never tried it in its "native" form.

mdmackillop
05-23-2010, 08:44 AM
Hi Oleg.
Always use Option Explicit.
Avoid looping where you can. Use Autofilter instead.
Split your code into smaller routines so each can be tested/debugged/reused as required
Do not colour entire rows unless you really need to. It just makes the file much bigger. (Excel7 has 16,384 columns)
Comment your code to detail what is meant to happen.
Here's a solution with some of these concepts (you can add your own comments!)

Option Explicit

Sub SAME2()
Dim Rng As Range
Dim cel As Range
Dim tgt As Range
Dim k As Long
Dim i As Long, y As Long
Dim myvar
Dim Sh1 As Worksheet
Dim sh2 As Worksheet
Set Sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
Application.ScreenUpdating = False
y = Sh1.Range("r65536").End(xlUp).Row
Set tgt = sh2.Range("a3")
Set Rng = Sh1.Range("r7:q" & y)
For Each cel In Rng
If Application.CountIf(Rng, cel) = 2 Then
cel.EntireRow.Copy
tgt.Offset(i).PasteSpecial
i = i + 1
If i = 57 Then Exit For
End If
Next

Call ColourResults(sh2)

Application.ScreenUpdating = True
End Sub

Sub ColourResults(ws As Worksheet)
Dim Rng As Range, r As Range
Dim u
Dim Clr As Long
Clr = 2
ws.Cells(2, "R") = "Data" 'Temp value
Set r = Range(ws.Cells(3, "A"), ws.Cells(Rows.Count, "r").End(xlUp)).Resize(, 20)
Set Rng = Range(ws.Cells(3, "r"), ws.Cells(Rows.Count, "r").End(xlUp))
'Filter on unique items
For Each u In Unique(Rng)
Clr = Clr + 1
ws.Cells(2, "R").AutoFilter field:=18, Criteria1:=u
r.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Clr
Next
ws.Cells(2, "R").AutoFilter
ws.Cells(2, "R") = "" 'Clear temp value
End Sub

'Get unique items from a range
Function Unique(Rng As Range)
Dim d, cel As Range
Set d = CreateObject("Scripting.dictionary")
On Error Resume Next
For Each cel In Rng
d.Add Item:=cel.Value, Key:=CStr(cel)
Next
On Error GoTo 0
Unique = d.items
End Function

oleg_v
05-24-2010, 12:41 AM
hi
thanks
if it not to hard for you can you please explain to me the lines from your code pasted below.

ws.Cells(2, "R") = "Data" 'Temp value
Set r = Range(ws.Cells(3, "A"), ws.Cells(Rows.Count, "r").End(xlUp)).Resize(, 20)
Set Rng = Range(ws.Cells(3, "r"), ws.Cells(Rows.Count, "r").End(xlUp))
'Filter on unique items
For Each u In Unique(Rng)
Clr = Clr + 1
ws.Cells(2, "R").AutoFilter Field:=18, Criteria1:=u
r.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Clr

Function Unique(Rng As Range)
Dim d, cel As Range
Set d = CreateObject("Scripting.dictionary")
On Error Resume Next
For Each cel In Rng
d.Add Item:=cel.Value, Key:=CStr(cel)
Next
On Error GoTo 0
Unique = d.items
End Function

thank you

GTO
05-24-2010, 04:36 AM
Hi All,

Might I respecfully suggest a couple of minor tweaks?

In SAME2()

'Set rng = Sh1.Range("r7:q" & y)
Set rng = Sh1.Range("R7:R" & y)
For Each cel In rng
If Application.CountIf(rng, cel) = 2 Then
cel.EntireRow.Copy
tgt.Offset(i).PasteSpecial
i = i + 1
'If i = 57 Then Exit For
End If
Next


In ColourResults()

For Each u In Unique(rng)
'Clr = Clr + 1
Clr = IIf(Clr < 56, Clr + 1, 3)

Once we ditch the IF i = 57..., we run out of colors. Maybe there's a better way(?) but this was what I came up with.

Oleg:

Certainly not to sway which way you turn your project in, but have you thought of sorting the rows in the destination sheet by the "part numbers" or whatever is in Col R? That way you could just rotate through several lighter shaded colors, and it would still be obvious what went with what. Just a thought.

Mark

PS - You are of course most welcome Malcom :beerchug: