Copy range depending on a cell values

[Closed]
Report
Posts
1
Registration date
Monday November 12, 2012
Status
Member
Last seen
November 12, 2012
-
Posts
2819
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 25, 2021
-
Hello,

i am looking for a script that gives me the following :

column A to D contains my data that I want to copy to another sheet, E/F contains my critera :

f.e for each row (<>"") range A,B,C will be copied "E" times to the sheet2 (in column A,B,C) AND IF F=1 I need to copy/paste an extra row with range A,B,D (in column A,B,C)

thanks for any help!!


4 replies

Posts
2819
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 25, 2021
487
Hi Isengard,

See if this script is to your liking:
Sub Test()
Dim lRow, x, y As Integer

Sheets("Sheet1").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Do
    x = x + 1
    y = Range("E" & x).Value
    Do
        Range(Cells(x, "A"), Cells(x, "C")).Copy _
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        y = y - 1
    Loop Until y = 0
    If Range("F" & x).Value = 1 Then
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("A" & x).Value
        Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("B" & x).Value
        Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("D" & x).Value
    End If
Loop Until x = lRow
End Sub


Best regards,
Trowa
Trowa,

thanx for the quick solution, it works as long as the value in "E" is >0 and not empty!
Any idea how I can solve this last issue?

best regards,
Kris
Posts
2819
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 25, 2021
487
Here you go Kris:

Sub Test()
Dim lRow, x, y As Integer

Sheets("Sheet1").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Do
    x = x + 1
    y = Range("E" & x).Value
    If y = 0 Then GoTo Next_x
    Do
        Range(Cells(x, "A"), Cells(x, "C")).Copy _
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        y = y - 1
    Loop Until y = 0
    If Range("F" & x).Value = 1 Then
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("A" & x).Value
        Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("B" & x).Value
        Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("D" & x).Value
    End If
Next_x:
Loop Until x = lRow
End Sub


Best regards,
Trowa
Great, but now i need an extra check , "If y = 0 Then GoTo Next_x" only if the value in column f for that row = 0...

Thanks!!!
Posts
2819
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 25, 2021
487
Hi Isengard,

I've honored your request, but what about you comments in your 14 nov post?

Sub Test()
Dim lRow, x, y As Integer

Sheets("Sheet1").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Do
    x = x + 1
    y = Range("E" & x).Value
    If y = 0 And Range("F" & x).Value = 0 Then GoTo Next_x
    Do
        Range(Cells(x, "A"), Cells(x, "C")).Copy _
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        y = y - 1
    Loop Until y = 0
    If Range("F" & x).Value = 1 Then
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("A" & x).Value
        Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("B" & x).Value
        Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
        Sheets("Sheet1").Range("D" & x).Value
    End If
Next_x:
Loop Until x = lRow
End Sub

Best regards,
Trowa