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