Hello ,

If somebody can help me out.

In a sheet the macro need to select all identical cells in column D that has the same text in it as cell D of the active row of the active cell and then copy the selected data to another sheet. After that it has to copy/paste several other columns but for the same rows selected.

For example...
The active cell is column K row 20. In this row in column D is 'AAA' registered. The macro had to to select in column D the cells above and below all the cells were also 'AAA' is registered (remarks; The cells are sorted so the ones with 'AAA' are always near each other, there is never another data registered in between of it).

Then this selected cells has to be copied to Sheet2 Cell A2.
The macro knows the range of selected rows. It should copy for the same rows the data from another column;
Column F to Sheet2 Cell B2
Column G to Sheet2 Cell C2
Column U to sheet2 Cell D2

Should be nice if I can get some help on it.

regards, Johan.

Hi Johan,

Am Thu, 20 Aug 2020 09:01:53 -0700 (PDT) schrieb :

In a sheet the macro need to select all identical cells in column D that has the same text in it as cell D of the active row of the active cell and then copy the selected data to another sheet. After that it has to copy/paste several other columns but for the same rows selected.

For example...
The active cell is column K row 20. In this row in column D is 'AAA' registered. The macro had to to select in column D the cells above and below all the cells were also 'AAA' is registered (remarks; The cells are sorted so the ones with 'AAA' are always near each other, there is never another data registered in between of it).

Then this selected cells has to be copied to Sheet2 Cell A2.
The macro knows the range of selected rows. It should copy for the same rows the data from another column;
Column F to Sheet2 Cell B2
Column G to Sheet2 Cell C2
Column U to sheet2 Cell D2

try:

Sub FindAndCopy()
Dim rngBig As Range, c As Range
Dim FirstAddress As String

With Sheets("Sheet1")
Set c = .Columns("D").Find(what:=.Range("D" & ActiveCell.Row), _
lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If rngBig Is Nothing Then
Set rngBig = Union(c, .Range("F" & c.Row & ":G" & c.Row), _
.Range("U" & c.Row))
Else
Set rngBig = Union(rngBig, c, _
.Range("F" & c.Row & ":G" & c.Row), .Range("U" & c.Row))
End If
Set c = .Columns("D").FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End With
rngBig.Copy Sheets("Sheet2").Range("A2")
End Sub


Regards
Claus B.
--
Windows10
Office 2016

Dear Claus,

Thanks a lot (again!).
Works perfect and clear to understand.

regards, Johan

I thought....... easy to change so it can fullfill my wished result :(
So I extended the code with the other columns that I need to copy, but....... in another different way.

------ changed code -------------------
Sub FindAndCopy()
Dim rngBig As Range, c As Range
Dim FirstAddress As String

With Sheets("Sheet1")
Set c = .Columns("D").Find(what:=.Range("D" & ActiveCell.Row), _
lookat:=xlWhole)

If Not c Is Nothing Then
FirstAddress = c.Address
Do

If rngBig Is Nothing Then
Set rngBig = Union(c, .Range("F" & c.Row & ":G" & c.Row), .Range("H" & c.Row), _
.Range("M" & c.Row), .Range("S" & c.Row), .Range("U" & c.Row), .Range("X" & c.Row), _
.Range("AA" & c.Row), .Range("AD" & c.Row), .Range("AG" & c.Row), .Range("AJ" & c.Row), .Range("AM" & c.Row), _
.Range("AB" & c.Row), .Range("AE" & c.Row), .Range("AH" & c.Row), .Range("AK" & c.Row), .Range("AN" & c.Row), _
.Range("AC" & c.Row), .Range("AF" & c.Row), .Range("AI" & c.Row), .Range("AL" & c.Row), .Range("AO" & c.Row))
Else
Set rngBig = Union(rngBig, c, .Range("F" & c.Row & ":G" & c.Row), .Range("H" & c.Row), _
.Range("M" & c.Row), .Range("S" & c.Row), .Range("U" & c.Row), .Range("X" & c.Row), _
.Range("AA" & c.Row), .Range("AD" & c.Row), .Range("AG" & c.Row), .Range("AJ" & c.Row), .Range("AM" & c.Row), _
.Range("AB" & c.Row), .Range("AE" & c.Row), .Range("AH" & c.Row), .Range("AK" & c.Row), .Range("AN" & c.Row), _
.Range("AC" & c.Row), .Range("AF" & c.Row), .Range("AI" & c.Row), .Range("AL" & c.Row), .Range("AO" & c.Row))
End If

Set c = .Columns("D").FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If
End With

rngBig.Copy Sheets("Sheet2").Range("A2")
End Sub
-------------------------
For the selected rows (with all the same text in column D) the copy result to Sheet2 should be in the order as changed now in the code resulting in;

Sheet1 - Sheet2
D - A
F - B
G - C
H - D
M - E
S - F
U - G
X - H
AA - I
AD - J
AG - K
AJ - L
AM - M
AB - N
AE - O
AH - P
AK - Q
AN - R
AC - S
AF - T
AI - U
AL - V
AO - W

But.............
The code copied to Sheet2 A till H in the correct column (oke).
but in column I till W the data is I=AA, J=AB, K=AC till W=AO instead of I=AA, J=AD, K=AG etc..
It looks like the code can, wrote on this way, only handle with columns in the normal order.

Question..... what is the solution. Can somebody explain me what to change in the code :)

regards, Johan

Hi Johan,

Am Sat, 22 Aug 2020 01:03:04 -0700 (PDT) schrieb :

I thought....... easy to change so it can fullfill my wished result :(
So I extended the code with the other columns that I need to copy, but....... in another different way.

But.............
The code copied to Sheet2 A till H in the correct column (oke).
but in column I till W the data is I=AA, J=AB, K=AC till W=AO instead of I=AA, J=AD, K=AG etc..
It looks like the code can, wrote on this way, only handle with columns in the normal order.

for me it works fine.
But here is another suggestion:

Sub FindAndCopy()
Dim rngBig As Range, c As Range
Dim FirstAddress As String
Dim varRows() As Variant, varCols As Variant
Dim strCols As String
Dim n As Integer, i As Integer

strCols = "D, F, G, H, M, S, U, X, AA, AD, AG, AJ, AM, AB, AE, AH, AK,
AN, AC, AF, AI, AL, AO"
varCols = Split(strCols, ", ")

With Sheets("Sheet1")
Set c = .Columns("D").Find(what:=.Range("D" & ActiveCell.Row), _
lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
ReDim Preserve varRows(n)
varRows(n) = c.Row
n = n + 1
Set c = .Columns("D").FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddress
End If

For i = LBound(varCols) To UBound(varCols)
For n = LBound(varRows) To UBound(varRows)
If rngBig Is Nothing Then
Set rngBig = .Range(varCols(i) & varRows(n))
Else
Set rngBig = Union(rngBig, .Range(varCols(i) & varRows(n)))
End If
Next n
rngBig.Copy Sheets("Sheet2").Cells(2, i + 1)
Set rngBig = Nothing
Next i
End With
End Sub


Regards
Claus B.
--
Windows10
Office 2016

Dear Claus,

You're the best !!
Thanks a lot :)

regards, Johan