VBA to move data if cell is greater than 1

[ItalianPlatinum]

Would someone be able to help me modify the below so column Q that starts on Q11 gets transferred (A-Q) for to sheet WsALL if the cell is greater than 1?

'transfer data over to Compare tab
  vCols = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17) '<- Columns of interest in specified order
  With WsSec
    With .Range("A11:Q" & .Range("H" & rows.count).End(xlUp).row)
            vRows = Application.Index(.Cells, Evaluate("row(1:" & .rows.count & ")"), Array(17))
            For ii = 1 To UBound(vRows)
                If Len(vRows(ii, 1)) > 1 Then
                    kk = kk + 1
                    vRows(kk, 1) = ii
        End If
      Next ii
        nrALL = WsALL.Range("A" & rows.count).End(xlUp).row + 1
        WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)
    End With
  End With

it errors here with runtime 1004

        WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)

 

[myall_blues]

I'm not sure exactly what you're doing with this - seeing some actual data would help - but from what I understand from your description and my limited testing it errors if there are no rows with a value in column Q.

You could fix that by testing for the value of the variable kk, like so:

    'transfer data over to Compare tab
    vCols = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17) '<- Columns of interest in specified order
    With WsSec
        With .Range("A11:Q" & .Range("H" & Rows.Count).End(xlUp).Row)
            vRows = Application.Index(.Cells, Evaluate("row(1:" & .Rows.Count & ")"), Array(17))
            For ii = 1 To UBound(vRows)
                If Len(vRows(ii, 1)) > 1 Then
                    kk = kk + 1
                    vRows(kk, 1) = ii
                End If
            Next ii
            nrALL = WsALL.Range("A" & Rows.Count).End(xlUp).Row + 1
            If kk > 0 Then
                WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)
            End If
        End With
    End With

 

[ItalianPlatinum]

So I solve for that previous to the code by doing this, therefore skipping if no 1 in column Q:

Set rng = .Range("Q11:Q" & lr1)
End With

If Application.WorksheetFunction.CountIf(rng, ">1") > 0 Then

Column Q used to be "Yes" but that data now is changing coming to me so I tried to modify accordingly just not sure if I am doing so properly. Q now will have numerical numbers any number greater than 0.

old code with Yes

If vRows(i, 1) = "Yes" Then

I just want to transfer all data from A-Q if Q has a number greater than 1 in it to WsAll next open row. Hope that helps clarify. The data is large so sharing is difficult but if you need a mockup of like 5 rows i can try to produce one for you and send via XLBB

 

[myall_blues]

Yes. Post a few lines of data and the complete code.

 

[ItalianPlatinum]

My code is very large so I am going to just send the snipbit that pertains to what we are trying to do here

WsSec is the source data
WsAll is the destination
WsCus is used to loop through the WsSec program

tax lot cons2.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3
4
5
6
7
8	D	9	A	C	L	T	Q	C	BC	OC	CUR	UC	BUY	UQ	CS
9
10	Date	Indicator	Account	SKU	Open Date	Lot #	QTY	Local Cost	Base Cost	Orig Cost	Currency	Unit Cost	Buyer	Unique Code	Rounded Unit Cost	Formula	Occurrence
11	22-May	A	ABC	G12345678	1/1/2020	1	10	100	100	100	USD	10	John	Z	10	_G1234567810	2
12	22-May	A	ABC	G12345678	1/1/2021	2	20	200	200	200	USD	10	Tom	x	10	_G1234567820	2
13	22-May	A	ABC	G12345678	9/1/1999	3	30	999	999	999	USD	33.3	Sally	c	33.3	_G1234567830	1
14	22-May	A	ABC	G12345678	1/6/1989	4	40	665	665	665	USD	16.625	Donna	v	16.63	_G1234567840	1
15	22-May	A	ABC	G12345678	10/15/2022	5	50	140	140	140	USD	2.8	Tim	f	2.8	_G1234567850	1
16	22-May	A	ABC	G12345678	6/6/1996	6	60	356	356	356	USD	5.933333333	Abigail	s	5.93	_G1234567860	1
17	22-May	A	ABC	G12345678	7/8/1990	7	70	9850	9850	9850	USD	140.7142857	Mike	s	140.71	_G1234567870	1
18	22-May	A	ABC	G12345678	4/9/2009	8	80	1584	1584	1584	USD	19.8	Chirstine	w	19.8	_G1234567880	1
19	22-May	A	ABC	G12345678	11/11/2005	9	90	4587	4587	4587	USD	50.96666667	Sabrina	t	50.97	_G1234567890	1
20	22-May	A	ABC	G12345678	10/1/2008	10	100	4587	4587	4587	USD	45.87	John	t	45.87	_G12345678100	1
Source

Cell Formulas
Range	Formula
O11:O20	O11	=ROUND(L11,2)
P11:P20	P11	="_"&D11&G11

t = Timer
' Run loop for range, clear, run, copy and paste into its respective sheet
  i = 0
  Do Until WsCus.Range("FILTER").Offset(i, 0) = ""
    FILTER = WsCus.Range("FILTER").Offset(i, 0)

'apply filter to start loop and activate sheet
With WsSec
    .Range("F4") = FILTER
    .Application.Calculation = xlManual
    .Activate
    .Range("A10").CurrentRegion.Delete
End With
Debug.Print "Worksheets(WsSec)Delete... :" & Format(Timer - t, "0.00") & " seconds"

t = Timer
    Call SecurityDistribution2
Debug.Print "Worksheets(WsSec)... :" & Format(Timer - t, "0.00") & " seconds"
 
'after execution copy from source and paste into sheet
With WsSec
lr1 = .Cells(rows.count, "A").End(xlUp).row 'find the maximum row
.Range("O10:Q10") = Array("Rounded 2 digit Unit Cost", "For formula", "Same Occurrence")
        .Application.Calculation = xlAutomatic
        .Range("P11:P" & lr1).NumberFormat = "General"
        .Range("O11:O" & lr1).Formula = "=Round(K11, 2)"
If TERMFLG = "L" Then
        .Range("P11:P" & lr1).Formula = "=""_""&D11&O11"
Else
        .Range("P11:P" & lr1).Formula = "=""_""&D11&E11&O11"
End If
        .Range("P11:P" & lr1).NumberFormat = "@"
        .Range("O11:P" & lr1).Value = .Range("O11:P" & lr1).Value
t = Timer
'countif formula
  Set dic = CreateObject("Scripting.Dictionary")
  a = .Range("P11:P" & lr1)
  ReDim b(1 To UBound(a, 1), 1 To 1)
  For k = 1 To UBound(a, 1)
      dic(a(k, 1)) = dic(a(k, 1)) + 1
  Next
  For k = 1 To UBound(a, 1)
    b(k, 1) = dic(a(k, 1))
  Next
        .Range("Q11").Resize(UBound(b, 1)).Value = b
        .Range("R11:R" & lr1).Formula = "=If(Q11>1,""Yes"",""No"")"
        .Range("R11:R" & lr1).Value = .Range("R11:R" & lr1).Value
Set rng = .Range("R11:R" & lr1)
End With

If Application.WorksheetFunction.CountIf(rng, "Yes") > 0 Then

'transfer data over to Compare tab
  vCols = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17) '<- Columns of interest in specified order
  With WsSec
    With .Range("A11:R" & .Range("H" & rows.count).End(xlUp).row)
            vRows = Application.Index(.Cells, Evaluate("row(1:" & .rows.count & ")"), Array(17))
            For ii = 1 To UBound(vRows)
                If vRows(ii, 1) > "1" Then
                    kk = kk + 1
                    vRows(kk, 1) = ii
        End If
      Next ii
        nrALL = WsALL.Range("A" & rows.count).End(xlUp).row + 1
        WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)
    End With
  End With
vRows = vbNullString
vCols = vbNullString
    End If

Debug.Print "CountIf Formula/delete... : " & Format(Timer - t, "0.00") & " seconds"
 
'apply filter to start and activate sheet
With WsSec
    .Application.Calculation = xlManual
    .Activate
    .Range("A10").CurrentRegion.Delete
End With
 
    i = i + 1
Loop

 

[myall_blues]

Apologies for the delay. It works fine for me. I used your data and this code subset:

Sub test()
    Dim vCols, vRows
    Dim WsSec As Worksheet, WsALL As Worksheet
    Dim nrALL As Long, ii As Long, kk As Long
    Set WsSec = Sheets("Sheet1")
    Set WsALL = Sheets("Sheet2")
    'transfer data over to Compare tab
    vCols = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17) '<- Columns of interest in specified order
    With WsSec
        With .Range("A11:R" & .Range("H" & Rows.Count).End(xlUp).Row)
            vRows = Application.Index(.Cells, Evaluate("row(1:" & .Rows.Count & ")"), Array(17))
            For ii = 1 To UBound(vRows)
                If vRows(ii, 1) > "1" Then
                    kk = kk + 1
                    vRows(kk, 1) = ii
                End If
            Next ii
            nrALL = WsALL.Range("A" & Rows.Count).End(xlUp).Row + 1
            WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)
        End With
    End With
End Sub

Also works if I change this

 If vRows(ii, 1) > "1" Then

to this

 If vRows(ii, 1) > 1 Then

 

[ItalianPlatinum]

Thanks for getting back to me I realized my issue was I am looping through that code and I am not clearing the variants after it was complete. That was causing me problems so I just added this at the end of the loop and it works

kk = 0
ii = 0
rng = 0

 

[ItalianPlatinum]

@myall_blues do you know if there is a size limit in VBA? I have a big data file and when trying to transfer over I get this error? im not at the excel row limit though so not sure what is going on

at this spot

            WsALL.Range("A" & nrALL).Resize(kk, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Index(vRows, 0, 1), vCols)

 

[ItalianPlatinum]

I'm going to start a new thread may be separate unrelated to the thread / new issue

 

[myall_blues]

Yes that would be best. I don’t know the answer so hopefully one of the big guns will chime in.