P
pano
Hi, anyone help with this macro when run if there is a number greater
than 0 in sheet1 V2 and a number greater than 0 in sheet1 AA2. This
macro copys and pastes twice instead of once. So I get the same rows
twice with the same data. I need somehow to check if there is a number
greater than 0 in both these cells and if so only copy once.
Thanks
Sub ATRANSPOSE_Click()
Dim R As Range
Dim p As Range
Dim Q As Range
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'Infring
Application.ScreenUpdating = False
Set R = ws.Range("V2", ws.Range("V37").End(xlUp))
For Each V In R.Cells
If Application.WorksheetFunction.IsNumber(V.Value) Then
If V.Value > 0 Then
V.Offset(0, -2).Range("A1:h1").Copy
Worksheets("1a").Range("E19").End(xlUp).Offset(1,
0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
End If
End If
Next V
'Orders
Set R = ws.Range("AA2", ws.Range("AA37").End(xlUp))
For Each AA In R.Cells
If Application.WorksheetFunction.IsNumber(AA.Value) Then
If AA.Value > 0 Then
AA.Offset(0, -7).Range("A1:h1").Copy
Worksheets("1a").Range("E19").End(xlUp).Offset(1,
0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
End If
End If
Next AA
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
than 0 in sheet1 V2 and a number greater than 0 in sheet1 AA2. This
macro copys and pastes twice instead of once. So I get the same rows
twice with the same data. I need somehow to check if there is a number
greater than 0 in both these cells and if so only copy once.
Thanks
Sub ATRANSPOSE_Click()
Dim R As Range
Dim p As Range
Dim Q As Range
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'Infring
Application.ScreenUpdating = False
Set R = ws.Range("V2", ws.Range("V37").End(xlUp))
For Each V In R.Cells
If Application.WorksheetFunction.IsNumber(V.Value) Then
If V.Value > 0 Then
V.Offset(0, -2).Range("A1:h1").Copy
Worksheets("1a").Range("E19").End(xlUp).Offset(1,
0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
End If
End If
Next V
'Orders
Set R = ws.Range("AA2", ws.Range("AA37").End(xlUp))
For Each AA In R.Cells
If Application.WorksheetFunction.IsNumber(AA.Value) Then
If AA.Value > 0 Then
AA.Offset(0, -7).Range("A1:h1").Copy
Worksheets("1a").Range("E19").End(xlUp).Offset(1,
0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
End If
End If
Next AA
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub