Copy row info but not in normal column sequence

[Howard]

A fairly simple macro to lookup the date posted in cell B1 and for each matching date in the named range DataA column, return data in a non sequential
manner.

As below the data returned is column 3, 1, 4 & 8. This works okay but the final version has 11 columns to return in a similar "scatter gun" method.

In this case it would be columns in this order from the DataA column C:

D, G, R, S, W, AF, AG, Y, AD, N & AE.

Making eleven different offset copy lines seems a bit clunky, but it would be the easiest for me, as I don't know how to skip various column and then return back to get them without the individual copy offsets.

Then the next hurdle is to return the data to C10 through M10 and downward from there.

Thanks,
Howard


Option Explicit

Sub DataACopy()

Dim DataA As Range
Dim c As Range
Dim aDate As String

aDate = Range("B1").Value

Application.ScreenUpdating = False
For Each c In Range("DataA")
If c.Value = aDate Then
c.Offset(, 3).Copy
Sheets("Sheet2").Range("C100").End(xlUp).Offset(1, 0).PasteSpecial

c.Offset(, 1).Copy
Sheets("Sheet2").Range("D100").End(xlUp).Offset(1, 0).PasteSpecial

c.Offset(, 4).Copy
Sheets("Sheet2").Range("E100").End(xlUp).Offset(1, 0).PasteSpecial

c.Offset(, 8).Copy
Sheets("Sheet2").Range("F100").End(xlUp).Offset(1, 0).PasteSpecial

End If
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

 

[Claus Busch]

Hi Howard,

Am Wed, 12 Jun 2013 10:41:43 -0700 (PDT) schrieb Howard:

In this case it would be columns in this order from the DataA column C:

D, G, R, S, W, AF, AG, Y, AD, N & AE.

Making eleven different offset copy lines seems a bit clunky, but it would be the easiest for me, as I don't know how to skip various column and then return back to get them without the individual copy offsets.

have a try:

Sub Test()
Dim myArr As Variant
Dim rngC As Range
Dim i As Integer
Dim j As Integer
Dim LRow As Long

myArr = Array("D", "G", "R", "S", "W", "AF", _
"AG", "Y", "AD", "N", "AE")

LRow = Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row
With Sheets("Sheet1")
For Each rngC In Range("DataA")
If rngC = .Range("B1") Then
LRow = LRow + 1
j = 3
For i = LBound(myArr) To UBound(myArr)
.Cells(rngC.Row, myArr(i)).Copy _
Sheets("Sheet2").Cells(LRow, j)
j = j + 1
Next i
End If
Next rngC
End With
End Sub


Regards
Claus Busch

 

[Howard]

have a try:

Sub Test()

Dim myArr As Variant

Dim rngC As Range

Dim i As Integer

Dim j As Integer

Dim LRow As Long



myArr = Array("D", "G", "R", "S", "W", "AF", _

"AG", "Y", "AD", "N", "AE")



LRow = Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row

With Sheets("Sheet1")

For Each rngC In Range("DataA")

If rngC = .Range("B1") Then

LRow = LRow + 1

j = 3

For i = LBound(myArr) To UBound(myArr)

.Cells(rngC.Row, myArr(i)).Copy _

Sheets("Sheet2").Cells(LRow, j)

j = j + 1

Next i

End If

Next rngC

End With

End Sub





Regards

Claus Busch

Thanks Claus,

Looking good. Just need it to copy to row C10 on first copy and on down with subsequent copies. Goes to C2 as is.

Howard

 

[Claus Busch]

Hi Howard,

Am Wed, 12 Jun 2013 11:51:51 -0700 (PDT) schrieb Howard:

Looking good. Just need it to copy to row C10 on first copy and on down with subsequent copies. Goes to C2 as is.

if the it always should copy to C10 then you can write:
LRow = 10
But if the table will become larger then try it with MAX. And j is not
needed:

Sub Test()
Dim myArr As Variant
Dim rngC As Range
Dim i As Integer
Dim LRow As Long

myArr = Array("D", "G", "R", "S", "W", "AF", _
"AG", "Y", "AD", "N", "AE")

LRow = Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row
LRow = WorksheetFunction.Max(9, LRow)
With Sheets("Sheet1")
For Each rngC In Range("DataA")
If rngC = .Range("B1") Then
LRow = LRow + 1
For i = LBound(myArr) To UBound(myArr)
.Cells(rngC.Row, myArr(i)).Copy _
Sheets("Sheet2").Cells(LRow, i + 3)
Next i
End If
Next rngC
End With
End Sub


Regards
Claus Busch

 

[Howard]

<But if the table will become larger then try it with MAX. And j is not
needed:>

Exactly what I needed.

As always, thanks a ton Claus.

Regards,
Howard

 

[Claus Busch]

Hi Howard,

Am Wed, 12 Jun 2013 12:14:33 -0700 (PDT) schrieb Howard:

Exactly what I needed.

a liitle step to optimize the code:
You can refer directly instead of copy and paste:
For i = LBound(myArr) To UBound(myArr)
Sheets("Sheet2").Cells(LRow, i + 3) = _
.Cells(rngC.Row, myArr(i))
Next i


Regards
Claus Busch

 

[Howard]

Hi Howard,



Am Wed, 12 Jun 2013 12:14:33 -0700 (PDT) schrieb Howard:






a liitle step to optimize the code:

You can refer directly instead of copy and paste:

For i = LBound(myArr) To UBound(myArr)

Sheets("Sheet2").Cells(LRow, i + 3) = _

.Cells(rngC.Row, myArr(i))

Next i





Regards

Claus Busch

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2

I'll plug that in and give it a try.

Thanks again.

Howard