copy range depending on a cell valuesClosed

Question

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!!


Configuration: Windows 7 / Firefox 16.0

TrowaD · Answer

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

isengard678 · Answer

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

Isengard678 · Answer

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!!!

TrowaD · Answer

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

Copy range depending on a cell values

4 responses

Similar discussions

Subscribe To Our Newsletter!