Copy Application.Union(c.Offset(0, 1), c.Offset(0, 2)... to a list onsame & another sheet

  • Thread starter Thread starter Howard
  • Start date Start date
H

Howard

Can I copy FndPrd to a list on the same sheet and/or to another sheet.
What I have gives me TRUE in K2 and I have marching ants around the
..Union arguments 1 & 2 and 3 & 4 on the sheet.

Thanks,
Howard

Option Explicit
Option Compare Text

Sub TheUnionOf()

Dim FndPrd As String
Dim c As Range

FndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = FndPrd Then
Set FndPrd = Application.Union(c.Offset(0, 1), c.Offset(0, 2), c.Offset(0, 4), c.Offset(0, 5))
Range("K100").End(xlUp).Offset(1, 0) = FndPrd
End If

Next
End Sub
 
Hi Howard,

Am Fri, 27 Sep 2013 23:55:51 -0700 (PDT) schrieb Howard:
Can I copy FndPrd to a list on the same sheet and/or to another sheet.
What I have gives me TRUE in K2 and I have marching ants around the
.Union arguments 1 & 2 and 3 & 4 on the sheet.
Click to expand...

try:

Sub TheUnionOf2()
Dim rngFndPrd As Range
Dim sFndPrd As String
Dim c As Range

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = sFndPrd Then
Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _
c.Offset(0, 4), c.Offset(0, 5))
rngFndPrd.Copy
Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True
End If
Next
End Sub

or:

Sub TheUnionOf()
Dim strFndPrd As String
Dim sFndPrd As String
Dim varOut As Variant
Dim c As Range

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = sFndPrd Then
strFndPrd = c.Offset(0, 1) & "," & c.Offset(0, 2) & "," & _
c.Offset(0, 4) & "," & c.Offset(0, 5)
varOut = Split(strFndPrd, ",")
Range("K100").End(xlUp).Offset(1, 0) _
.Resize(rowsize:=UBound(varOut) + 1) = _
WorksheetFunction.Transpose(varOut)
End If
Next
End Sub


Regards
Claus B.
 
Hi Howard,



Am Fri, 27 Sep 2013 23:55:51 -0700 (PDT) schrieb Howard:








try:



Sub TheUnionOf2()

Dim rngFndPrd As Range

Dim sFndPrd As String

Dim c As Range



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

If c = sFndPrd Then

Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _

c.Offset(0, 4), c.Offset(0, 5))

rngFndPrd.Copy

Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _

Paste:=xlPasteAll, Transpose:=True

End If

Next

End Sub



or:



Sub TheUnionOf()

Dim strFndPrd As String

Dim sFndPrd As String

Dim varOut As Variant

Dim c As Range



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

If c = sFndPrd Then

strFndPrd = c.Offset(0, 1) & "," & c.Offset(0, 2) & "," & _

c.Offset(0, 4) & "," & c.Offset(0, 5)

varOut = Split(strFndPrd, ",")

Range("K100").End(xlUp).Offset(1, 0) _

.Resize(rowsize:=UBound(varOut) + 1) = _

WorksheetFunction.Transpose(varOut)

End If

Next

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

Thanks, Claus. Both run smooth and good as gold.

Regards,
Howard
 
Hi Howard,

Am Sat, 28 Sep 2013 00:50:09 -0700 (PDT) schrieb Howard:
Both run smooth and good as gold.
Click to expand...

it will run a bit faster if you use the find method instead of looping
through the range:

Sub TheUnionOf2()
Dim rngFndPrd As Range
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Set c = Range("A1:A" & LRow).Find(sFndPrd, LookIn:=xlValues)
If Not c Is Nothing Then
Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _
c.Offset(0, 4), c.Offset(0, 5))
rngFndPrd.Copy
Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True
End If
End Sub


Regards
Claus B.
 
it will run a bit faster if you use the find method instead of looping

through the range:



Sub TheUnionOf2()

Dim rngFndPrd As Range

Dim sFndPrd As String

Dim c As Range

Dim LRow As Long



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



LRow = Cells(Rows.Count, 1).End(xlUp).Row

Set c = Range("A1:A" & LRow).Find(sFndPrd, LookIn:=xlValues)

If Not c Is Nothing Then

Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _

c.Offset(0, 4), c.Offset(0, 5))

rngFndPrd.Copy

Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _

Paste:=xlPasteAll, Transpose:=True

End If

End Sub
Click to expand...
Regards

Claus B.
Click to expand...


I'll give it a go. I'm using the codes on a small test data set, actual use could be around 5500+ rows.

I'm sure that will make a BIG difference.

Thanks, Claus.

Appreciate it.

Regards,
Howard
 
Hi Howard,

Am Sat, 28 Sep 2013 03:33:06 -0700 (PDT) schrieb Howard:
I'll give it a go. I'm using the codes on a small test data set, actual use could be around 5500+ rows.
Click to expand...

can your search string be found more than once? Then try:

Sub TheUnionOf3()
Dim varOut() As Variant
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long
Dim firstaddress As String
Dim i As Integer
Dim j As Integer
Dim myCount As Integer

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

LRow = Cells(Rows.Count, 1).End(xlUp).Row
myCount = WorksheetFunction.CountIf(Range("A1:A" & LRow), sFndPrd)
With Range("A1:A" & LRow)
i = 1
Set c = .Find(sFndPrd, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ReDim Preserve varOut(myCount, 4)
varOut(i, 1) = c.Offset(0, 1)
varOut(i, 2) = c.Offset(0, 2)
varOut(i, 3) = c.Offset(0, 4)
varOut(i, 4) = c.Offset(0, 5)
Set c = .FindNext(c)
i = i + 1
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
.Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount, 4) = varOut
' .Cells(Rows.Count, "K").End(xlUp)(2) _
' .Resize(4, myCount) = WorksheetFunction.Transpose(varOut)
End With
End Sub


Regards
Claus B.
 
Hi Howard,



Am Sat, 28 Sep 2013 03:33:06 -0700 (PDT) schrieb Howard:






can your search string be found more than once? Then try:



Sub TheUnionOf3()

Dim varOut() As Variant

Dim sFndPrd As String

Dim c As Range

Dim LRow As Long

Dim firstaddress As String

Dim i As Integer

Dim j As Integer

Dim myCount As Integer



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



LRow = Cells(Rows.Count, 1).End(xlUp).Row

myCount = WorksheetFunction.CountIf(Range("A1:A" & LRow), sFndPrd)

With Range("A1:A" & LRow)

i = 1

Set c = .Find(sFndPrd, LookIn:=xlValues)

If Not c Is Nothing Then

firstaddress = c.Address

Do

ReDim Preserve varOut(myCount, 4)

varOut(i, 1) = c.Offset(0, 1)

varOut(i, 2) = c.Offset(0, 2)

varOut(i, 3) = c.Offset(0, 4)

varOut(i, 4) = c.Offset(0, 5)

Set c = .FindNext(c)

i = i + 1

Loop While Not c Is Nothing And c.Address <> firstaddress

End If

.Cells(Rows.Count, "K").End(xlUp)(2) _

.Resize(myCount, 4) = varOut

' .Cells(Rows.Count, "K").End(xlUp)(2) _

' .Resize(4, myCount) = WorksheetFunction.Transpose(varOut)

End With

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

I was just ready to post back after trying the find method, for that very reason.

The search string will almost always be in multiples and the return values for identical strings will be different as the code goes down the list in column A. So the end product will be a progression of changes relative to the search string as it is found on down the line.

I'll give this newest code a test flight.

I would like the option to produce the out come list to another sheet also.

Would it look something like this if data was on sheet 10?


Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount, 4) = varOut

Howard
 
Hi Howard,
Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount, 4) = varOut
Click to expand...

that is correct. But you must have Sheet10 active when running the macro
or you have to reference to Sheet10 into the code


Regards
Claus B.
 
Hi Howard,







that is correct. But you must have Sheet10 active when running the macro

or you have to reference to Sheet10 into the code





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

I plugged that in an indeed it works. Got lucky there..<lol>.

One problem with the last code, it misses I entry of all the ones I've tried.

Column A is 1 to 10 with three different search strings. If there are four duplicates it returns three results. Three duplicates returns two. I cannot detect any pattern, it just returns 1 less than exist in the list.

Howard
 
Hi Howard,

Am Sat, 28 Sep 2013 04:14:09 -0700 (PDT) schrieb Howard:
One problem with the last code, it misses I entry of all the ones I've tried.
Click to expand...

the last two lines are only if you want to transpose the array. If you
don't want, delete these lines. If you want to transpose, delete the two
lines in front.
But don't run both.

Regards
Claus B.
 
Hi again,

Am Sat, 28 Sep 2013 04:14:09 -0700 (PDT) schrieb Howard:
Column A is 1 to 10 with three different search strings. If there are four duplicates it returns three results. Three duplicates returns two. I cannot detect any pattern, it just returns 1 less than exist in the list.
Click to expand...

my bad :-(
Change it to:
Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount + 1, 4) = varOut


Regards
Claus B.
 
Hi Howard,

Am Sat, 28 Sep 2013 13:28:06 +0200 schrieb Claus Busch:
Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount + 1, 4) = varOut
Click to expand...

but now:
Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount + 1, 5) = varOut


Regards
Claus B.
 
Hi Howard,



Am Sat, 28 Sep 2013 04:14:09 -0700 (PDT) schrieb Howard:






the last two lines are only if you want to transpose the array. If you

don't want, delete these lines. If you want to transpose, delete the two

lines in front.

But don't run both.



Regards

Claus B.
Click to expand...

I left the last two lines commented out. What I see is that it seems to over write the previous posting. The xlUp offset used in the earlier code worsk like I want it to, but coming from the top down to make the list makes more sense to me.

Howard
 
Hi Howard,



Am Sat, 28 Sep 2013 13:28:06 +0200 schrieb Claus Busch:







but now:

Sheets("Sheet11").Cells(Rows.Count, "K").End(xlUp)(2) _

.Resize(myCount + 1, 5) = varOut





Regards

Claus B.
Click to expand...


I missed that it was not returning all four column, the last correction solves that.

I still have the overwrite problem, It seems to post the input search string correctly, but if I want to search another string, then that result is posted over the previous, instead of compiling a list..

Howard
 
Hi Howard,

Am Sat, 28 Sep 2013 04:51:12 -0700 (PDT) schrieb Howard:
I still have the overwrite problem, It seems to post the input search string correctly, but if I want to search another string, then that result is posted over the previous, instead of compiling a list..
Click to expand...

sorry, I forgot a important thing:
Option Base 1.
Try:

Option Explicit
Option Base 1

Sub TheUnionOf3()
Dim varOut() As Variant
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long
Dim FERow As Range
Dim firstaddress As String
Dim i As Integer
Dim myCount As Integer

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)
With Sheets("Sheet10")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
myCount = WorksheetFunction.CountIf(.Range("A1:A" & LRow), sFndPrd)
With .Range("A1:A" & LRow)
i = 1
Set c = .Find(sFndPrd, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ReDim Preserve varOut(myCount, 4)
varOut(i, 1) = c.Offset(0, 1)
varOut(i, 2) = c.Offset(0, 2)
varOut(i, 3) = c.Offset(0, 4)
varOut(i, 4) = c.Offset(0, 5)
Set c = .FindNext(c)
i = i + 1
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End With

With Sheets("Sheet11")
Set FERow = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)
FERow.Resize(myCount, 4) = varOut
End With
End Sub


Regards
Claus B.
 
Hi Howard,



Am Sat, 28 Sep 2013 04:51:12 -0700 (PDT) schrieb Howard:






sorry, I forgot a important thing:

Option Base 1.

Try:



Option Explicit

Option Base 1



Sub TheUnionOf3()

Dim varOut() As Variant

Dim sFndPrd As String

Dim c As Range

Dim LRow As Long

Dim FERow As Range

Dim firstaddress As String

Dim i As Integer

Dim myCount As Integer



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)

With Sheets("Sheet10")

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

myCount = WorksheetFunction.CountIf(.Range("A1:A" & LRow), sFndPrd)

With .Range("A1:A" & LRow)

i = 1

Set c = .Find(sFndPrd, LookIn:=xlValues)

If Not c Is Nothing Then

firstaddress = c.Address

Do

ReDim Preserve varOut(myCount, 4)

varOut(i, 1) = c.Offset(0, 1)

varOut(i, 2) = c.Offset(0, 2)

varOut(i, 3) = c.Offset(0, 4)

varOut(i, 4) = c.Offset(0, 5)

Set c = .FindNext(c)

i = i + 1

Loop While Not c Is Nothing And c.Address <> firstaddress

End If

End With

End With



With Sheets("Sheet11")

Set FERow = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)

FERow.Resize(myCount, 4) = varOut

End With

End Sub


Regards

Claus B.
Click to expand...


That stacks them in there just right.

Once again, thanks Claus.

Regards,
Howard
 
Not sure what or how I screwed this up, as it was working just fine until I made some small changes.

123
456
789
147
258
369
321
654
987

These are my search strings and are on Sheet 1 in Col G w/Header.
They are repeated four times down col G.

I want to return six offsets from the column G search string chosen and they are: H, J, L, N, P, R

So with any search string I would have four rows of offsets on Sheet 2
K through P and the search string listed once in col J.

Strangely if I select 123 as the search string I get the first set of offsets ONLY, search string is correctly in col J. I should have three more rows of offset data.

If I select 456 I get an error 400 with only the search string entered in col J.

Scratching my head???

Thanks,
Howard

Option Explicit
Option Base 1
Option Compare Text

Sub TheUnionOfOpBaseOneClaus()
Dim varOut() As Variant
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long

Dim FERow As Range

Dim firstaddress As String
Dim i As Integer

Dim myCount As Integer

sFndPrd = Application.InputBox("Enter Col G Item.", _
"Col G Finder", , , , , , 2)

Sheets("Sheet2").Range("K100").End(xlUp).Offset(1, -1) = sFndPrd

With Sheets("Sheet1")
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
myCount = WorksheetFunction.CountIf(.Range("G2:G" & LRow), sFndPrd)
With .Range("G2:G" & LRow)

i = 1
Set c = .Find(sFndPrd, LookIn:=xlValues)

If Not c Is Nothing Then
firstaddress = c.Address
Do
ReDim Preserve varOut(myCount, 6)
varOut(i, 1) = c.Offset(0, 1)
varOut(i, 2) = c.Offset(0, 3)
varOut(i, 3) = c.Offset(0, 5)
varOut(i, 4) = c.Offset(0, 7)
varOut(i, 5) = c.Offset(0, 9)
varOut(i, 6) = c.Offset(0, 11)
Set c = .FindNext(c)
i = i + 1
Loop While Not c Is Nothing And c.Address <> firstaddress
End If

End With
End With

With Sheets("Sheet2")
Set FERow = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)
FERow.Resize(myCount, 6) = varOut
End With
End Sub
 
Not sure what or how I screwed this up, as it was working just fine until I made some small changes.



123

456

789

147

258

369

321

654

987



These are my search strings and are on Sheet 1 in Col G w/Header.

They are repeated four times down col G.



I want to return six offsets from the column G search string chosen and they are: H, J, L, N, P, R



So with any search string I would have four rows of offsets on Sheet 2

K through P and the search string listed once in col J.



Strangely if I select 123 as the search string I get the first set of offsets ONLY, search string is correctly in col J. I should have three more rows of offset data.



If I select 456 I get an error 400 with only the search string entered in col J.



Scratching my head???



Thanks,

Howard



Option Explicit

Option Base 1

Option Compare Text



Sub TheUnionOfOpBaseOneClaus()

Dim varOut() As Variant

Dim sFndPrd As String

Dim c As Range

Dim LRow As Long



Dim FERow As Range



Dim firstaddress As String

Dim i As Integer



Dim myCount As Integer



sFndPrd = Application.InputBox("Enter Col G Item.", _

"Col G Finder", , , , , , 2)



Sheets("Sheet2").Range("K100").End(xlUp).Offset(1, -1) = sFndPrd



With Sheets("Sheet1")

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

myCount = WorksheetFunction.CountIf(.Range("G2:G" & LRow), sFndPrd)

With .Range("G2:G" & LRow)



i = 1

Set c = .Find(sFndPrd, LookIn:=xlValues)



If Not c Is Nothing Then

firstaddress = c.Address

Do

ReDim Preserve varOut(myCount, 6)

varOut(i, 1) = c.Offset(0, 1)

varOut(i, 2) = c.Offset(0, 3)

varOut(i, 3) = c.Offset(0, 5)

varOut(i, 4) = c.Offset(0, 7)

varOut(i, 5) = c.Offset(0, 9)

varOut(i, 6) = c.Offset(0, 11)

Set c = .FindNext(c)

i = i + 1

Loop While Not c Is Nothing And c.Address <> firstaddress

End If



End With

End With



With Sheets("Sheet2")

Set FERow = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)

FERow.Resize(myCount, 6) = varOut

End With

End Sub
Click to expand...

I found my error!

I moved my search strings to column G and made code changes to accommodate that.

I failed to change

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

to

LRow = .Cells(.Rows.Count, 7).End(xlUp).Row

Is working fine now.

Howard
 
I found my error!
I moved my search strings to column G and made code changes to
accommodate that.

I failed to change

LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

to

LRow = .Cells(.Rows.Count, 7).End(xlUp).Row

Is working fine now.
Click to expand...

Just want to emphasize that using defined name for the search string
col doesn't break your code...

Dim lSearchStrCol&
lSearchStrCol = Range("SearchStrings").Column
LRow = .Cells(.Rows.Count, lSearchStrCol).End(xlUp).Row

OR

LRow = .Cells(.Rows.Count, Range("SearchStrings").Column).End(xlUp).Row

...because Excel will always know where it is!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Back
Top