Need assistance to write a macro that does the following

[stanleysi]

Hi all,

Gravely need some assistance to write a macro that can do the following:
Where A1,A2,C3 etc are values (in this case, A2,B2,C2 and D2 as well as A3,B3,C3,and D3 "belong" to A1 and A6,B6,C6 and D6 belong to A5 and a blank row seperates A1 family and A5 family

Sheet1

A B C D E F
1 A1
2 A2 B2 C2 D2
3 A3 B3 C3 D3
4 (blank row)
5 A5
6 A6 B6 C6 D6
7 (blank row)
8

I need a macro that can trigger the values from this sheet to be copied to Sheet2 where the family the values belong to are sorted in Column D as below

Sheet2 output should be
A B C D E F
1 (blank row)
2 B2 C2 D2 A1
3 B3 C3 D3 A1
4 B6 C6 D6 A5
5

Can anyone please help? This is rather urgent.

Thanks!

Stanley

[K Dales]

The below should work but one note: in your example you "lose" the values A3,
A5 and A6. I wrote the sub accordingly but if not the indicated lines need
to be changed:

Sub CopyRows()
Dim SourceRow As Integer, DestRow As Integer
Dim LastRow As Integer
Dim Family As Variant

On Error GoTo Err

DestRow = 2
LastRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row

Application.ScreenUpdating = False

With Worksheets("Sheet1")
For SourceRow = 1 To LastRow
If .Cells(SourceRow, 1) <> "" Then
If .Cells(SourceRow, 2) = "" Then
Family = .Cells(SourceRow, 1).Value
Else
.Range("B" & SourceRow & ":D" & SourceRow).Copy
' or "A" instead of "B" if you need to copy the first value
also
Worksheets("Sheet2").Range("A" & DestRow).PasteSpecial
xlPasteAll
Worksheets("Sheet2").Range("D" & DestRow).Value = Family
' or Range("E" & DestRow) if you copied 4 columns instead of 3
DestRow = DestRow + 1
End If
End If
Next SourceRow
End With

Err:
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

--
- K Dales


"stanleysi" wrote:

>
> Hi all,
>
> Gravely need some assistance to write a macro that can do the
> following:
> Where A1,A2,C3 etc are values (in this case, A2,B2,C2 and D2 as well as
> A3,B3,C3,and D3 "belong" to A1 and A6,B6,C6 and D6 belong to A5 and a
> blank row seperates A1 family and A5 family
>
> Sheet1
>
> A B C D E F
> 1 A1
> 2 A2 B2 C2 D2
> 3 A3 B3 C3 D3
> 4 (blank row)
> 5 A5
> 6 A6 B6 C6 D6
> 7 (blank row)
> 8
>
> I need a macro that can trigger the values from this sheet to be copied
> to Sheet2 where the family the values belong to are sorted in Column D
> as below
>
> Sheet2 output should be
> A B C D E F
> 1 (blank row)
> 2 B2 C2 D2 A1
> 3 B3 C3 D3 A1
> 4 B6 C6 D6 A5
> 5
>
> Can anyone please help? This is rather urgent.
>
> Thanks!
>
> Stanley
>
>
> --
> stanleysi
> ------------------------------------------------------------------------
> stanleysi's Profile: http://www.excelforum.com/member.php...fo&userid=8893
> View this thread: http://www.excelforum.com/showthread...hreadid=544747
>
>

[stanleysi]

Hiya!

Thanks for the prompt reply. I tried the code but ran into some problems when it hit the "also" function? I removed that and reran it but all i got in Sheet 2 is the following error : Invalid Use of Property for xlPasteAll

I am thinking if should be :
Worksheets("Sheet2").Range("A" & DestRow).PasteSpecial (xlPasteAll)

I changed that and also :

.Range("B" & SourceRow & ":D" & SourceRow).Copy
to
.Range("B" & SourceRow & "D" & SourceRow).Copy

I ran the above and got er .. nothing

Help! ...

Basically this is what I changed it to :
Sub CopyRows()
Dim SourceRow As Integer, DestRow As Integer
Dim LastRow As Integer
Dim Family As Variant

On Error GoTo Err

DestRow = 2
LastRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row

Application.ScreenUpdating = False

With Worksheets("Sheet1")
For SourceRow = 1 To LastRow
If .Cells(SourceRow, 1) <> "" Then
If .Cells(SourceRow, 2) = "" Then
Family = .Cells(SourceRow, 1).Value
Else
.Range("B" & SourceRow & "D" & SourceRow).Copy also
' or "A" instead of "B" if you need to copy the first value
Worksheets("Sheet2").Range("A" & DestRow).PasteSpecial (xlPasteAll)
Worksheets("Sheet2").Range("D" & DestRow).Value = Family
' or Range("E" & DestRow) if you copied 4 columns instead of 3
DestRow = DestRow + 1
End If
End If
Next SourceRow
End With

Err:
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


Stan

The below should work but one note: in your example you "lose" the values A3,
A5 and A6. I wrote the sub accordingly but if not the indicated lines need
to be changed:

Sub CopyRows()
Dim SourceRow As Integer, DestRow As Integer
Dim LastRow As Integer
Dim Family As Variant

On Error GoTo Err

DestRow = 2
LastRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row

Application.ScreenUpdating = False

With Worksheets("Sheet1")
For SourceRow = 1 To LastRow
If .Cells(SourceRow, 1) <> "" Then
If .Cells(SourceRow, 2) = "" Then
Family = .Cells(SourceRow, 1).Value
Else
.Range("B" & SourceRow & ":D" & SourceRow).Copy
' or "A" instead of "B" if you need to copy the first value
also
Worksheets("Sheet2").Range("A" & DestRow).PasteSpecial
xlPasteAll
Worksheets("Sheet2").Range("D" & DestRow).Value = Family
' or Range("E" & DestRow) if you copied 4 columns instead of 3
DestRow = DestRow + 1
End If
End If
Next SourceRow
End With

Err:
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

--
- K Dales


"stanleysi" wrote:

>
> Hi all,
>
> Gravely need some assistance to write a macro that can do the
> following:
> Where A1,A2,C3 etc are values (in this case, A2,B2,C2 and D2 as well as
> A3,B3,C3,and D3 "belong" to A1 and A6,B6,C6 and D6 belong to A5 and a
> blank row seperates A1 family and A5 family
>
> Sheet1
>
> A B C D E F
> 1 A1
> 2 A2 B2 C2 D2
> 3 A3 B3 C3 D3
> 4 (blank row)
> 5 A5
> 6 A6 B6 C6 D6
> 7 (blank row)
> 8
>
> I need a macro that can trigger the values from this sheet to be copied
> to Sheet2 where the family the values belong to are sorted in Column D
> as below
>
> Sheet2 output should be
> A B C D E F
> 1 (blank row)
> 2 B2 C2 D2 A1
> 3 B3 C3 D3 A1
> 4 B6 C6 D6 A5
> 5
>
> Can anyone please help? This is rather urgent.
>
> Thanks!
>
> Stanley
>
>
> --
> stanleysi
> ------------------------------------------------------------------------
> stanleysi's Profile: http://www.excelforum.com/member.php...fo&userid=8893
> View this thread: http://www.excelforum.com/showthread...hreadid=544747
>
>