blastpwr1970
12-13-2006, 02:59 PM
Hi all,
I tried different things and nothing seems to work, could somebody please help me.
I need to search for MyText1, MyText2,.........MyText40.
The only way that I know how to do it is by repeting the code over and over again.
Is it posible to either do it with a lookup table or any other way?
I got too many part numbers to repeat the code over and over again.
Please help me.
In reference to http://www.vbaexpress.com/forum/showthread.php?t=8283
Option Explicit
Sub Macro1()
Dim i As Long, Txt As String
Dim Col1 As Range, Col2 As Range
Txt = "MyText"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Txt = "MyText1"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Txt = "MyText2"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Sheets(2).Activate
End Sub
:banghead: Thank you for all the help you can provide.
I tried different things and nothing seems to work, could somebody please help me.
I need to search for MyText1, MyText2,.........MyText40.
The only way that I know how to do it is by repeting the code over and over again.
Is it posible to either do it with a lookup table or any other way?
I got too many part numbers to repeat the code over and over again.
Please help me.
In reference to http://www.vbaexpress.com/forum/showthread.php?t=8283
Option Explicit
Sub Macro1()
Dim i As Long, Txt As String
Dim Col1 As Range, Col2 As Range
Txt = "MyText"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Txt = "MyText1"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Txt = "MyText2"
Set Col1 = Intersect(Columns(Range("1:1").Find(What:="Look2", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
Set Col2 = Intersect(Columns(Range("1:1").Find(What:="Test3", LookIn:=xlValues, _
LookAt:=xlWhole).Column), ActiveSheet.UsedRange)
For i = 1 To Col1.Rows.Count
If Col1(i) = True And Left(Col2(i), Len(Txt)) = Txt Then
Rows(i).Copy Sheets(2).Cells(65536, _
Col1.Column).End(xlUp).Offset(1, -Col1.Column + 1)
End If
Next
Sheets(2).Activate
End Sub
:banghead: Thank you for all the help you can provide.