Avoiding copy/paste, selection to transfer data in VBA

[ItalianPlatinum]

Looking for a way to transfer a set of data over to another sheet after i set a filter without copy, selecting or pasting.

1. Sheet 1: filtered to not show blanks
   1. Want to transfer the data left showing
2. Sheet 2: Where I want to transfer the data to
3. Columns match up like this:
   1. Column A to Column A13 down
   2. Column I to Column B13 down
   3. Column J to Column C13 down
   4. so on and so on.....

 

[Peter_SSs]

Looking for a way to transfer a set of data over to another sheet after i set a filter without copy, selecting or pasting.

OK, give this a try with a copy of your workbook

Sub TransferData()
  Dim vRows As Variant, vCols As Variant

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(row(#)>2,row(#),""x""),""x"")", "#", .Columns(9).Address(External:=True)))), "x", False)
      Sheets("Compare").Range("A13").Resize(UBound(vRows), UBound(vCols)).Value = Application.Index(.Cells.Value, Application.Transpose(vRows), vCols)
    End With
  End With
End Sub

 

[ZVI]

Hi Peter,
It's impressive & short code!
The only limitation is an array limit of the Application.Transpose:

Debug.Print UBound(Application.Transpose(Range("A1:A100000")))

Not sure if it's critical - depends on max number of data rows in the sheet "Periodic".

 

[ZVI]

Another solution to test:

Sub TransferData1()
 
  Dim a() As Variant
  Dim Sh1 As Worksheet, Sh2 As Worksheet
  Dim Rng1 As Range, Rng2 As Range
  Dim i As Long, j As Long
 
  ' Set variables for sheets and ranges
  Set Sh1 = Sheets("Periodic")
  Set Sh2 = Sheets("Compare")
  i = Sh1.Cells(Rows.Count, "A").End(xlUp).Row ' Last data row
  Set Rng1 = Sh1.Range("A3").Resize(i - 2)
  Set Rng2 = Sh2.Range("A3").Resize(i - 2)
 
  ' Copy the not filtered data
  Rng2.Columns("A").Value = Rng1.Columns("A").Value
  Rng2.Columns("B:D").Value = Rng1.Columns("I:K").Value
  Rng2.Columns("E:I").Value = Rng1.Columns("B:F").Value
 
  ' Get filter  criteria from Rng1.Columns("I")
  a() = Rng1.Columns("I").Value
  For j = 1 To UBound(a)
    If Len(a(j, 1)) <> 0 Then a(j, 1) = 1
  Next
 
  ' Freeze
  Application.ScreenUpdating = False
  Application.EnableEvents = False
 
  ' Filter using an extra column, it's fast
  Sh2.Columns(1).Insert xlShiftToRight
  With Rng2.Offset(, -1).Resize(, 10)
    .Columns(1).Value = a()
    .Sort .Cells(1), xlAscending, Header:=xlNo
    j = .Cells(1).Offset(UBound(a)).End(xlUp).Row
    If i > j Then .Rows(j - .Row + 2 & ":" & i).ClearContents
  End With
  Sh2.Columns(1).Delete
 
  ' Unfreeze
  Application.ScreenUpdating = True
  Application.EnableEvents = True
 
End Sub

 

[Peter_SSs]

I forgot to mention that my codes (& I think Vlad's?) do not require column I to be Filtered for blanks. In fact, if you are only doing that to get the non-blank data to the other sheet then it would be better to not filter it first as it will save some time.

I should also mention

• My earlier code resulted in one row and one column of the results missing - corrected below assuming Option Base has not been set to 1.
• Formula recalculation due to filtering, column insertion etc could affect speed of code. However, the only recalculations that my codes should trigger are if there are any formulas that are triggered by changes to sheet 'Compare' A13:K13 and below

Code corrected from post 21

Sub TransferData()
  Dim vRows As Variant, vCols As Variant

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(row(#)>2,row(#),""x""),""x"")", "#", .Columns(9).Address(External:=True)))), "x", False)
      Sheets("Compare").Range("A13").Resize(UBound(vRows) + 1, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Transpose(vRows), vCols)
    End With
  End With
End Sub

The only limitation is an array limit of the Application.Transpose:

Hi Vlad
Yes, that could be a problem. Need to know the size of the data as you say.
Or I could fill the vRows array looping in a similar way to you have with your 'a' array above. In testing up to about 200,000 rows the time difference between my earlier code and the one below is negligible. These codes for me are running 2 - 3 times faster than the post 23 code but that may not be relevant as it produces different results to mine - see my results below.

Sub TransferData_v2()
  Dim vCols As Variant, vRows As Variant
  Dim i As Long, k As Long

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = .Columns(9).Value
      For i = 3 To UBound(vRows)
        If Len(vRows(i, 1)) > 0 Then
          k = k + 1
          vRows(k, 1) = i
        End If
      Next i
      Sheets("Compare").Range("A13").Resize(k, UBound(vCols)).Value = Application.Index(.Cells.Value, vRows, vCols)
    End With
  End With
End Sub

My (small) sample data

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1
2	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 6	Hdr 7	Hdr 8	Hdr 9	Hdr 10	Hdr 11
3	39	52	30	37	51	66	6	71	50	41	48
4	34	57	57	25	78	59	71	31	23	70	64
5	43	81	54	51	2	81	37	81		30	62
6	79	35	74	40	57	82	35	52	16	28	32
7	5	26	20	66	45	90	77	44	18	6	72
8	32	22	16	23	19	41	49	76		37	1
9	35	40	11	44	3	14	94	68		41	88
10	38	77	14	77	16	26	45	77		6	22
11	31	13	91	54	19	37	14	11		48	90
12	82	18	56	37	89	80	71	61	60	99	95
13	81	2	35	89	10	40	56	67	77	6	87
14	43	72	23	60	52	67	28	55	71	68	60
15	3	3	83	81	93	41	59	84	12	10	47
16	36	61	74	15	80	95	20	82		15	26
17	4	57	78	33	66	76	86	45		86	6
18	88	17	97	9	88	88	17	74	33	27	39
19	26	97	80	9	39	15	33	85	23	94	16
20	22	22	26	9	57	22	95	64		1	5
21	90	91	98	86	7	48	16	62		81	7
Periodic

.. and corresponding results (using v2 code)

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
13	39	50	41	48	52	30	37	51	66	6	71
14	34	23	70	64	57	57	25	78	59	71	31
15	79	16	28	32	35	74	40	57	82	35	52
16	5	18	6	72	26	20	66	45	90	77	44
17	82	60	99	95	18	56	37	89	80	71	61
18	81	77	6	87	2	35	89	10	40	56	67
19	43	71	68	60	72	23	60	52	67	28	55
20	3	12	10	47	3	83	81	93	41	59	84
21	88	33	27	39	17	97	9	88	88	17	74
22	26	23	94	16	97	80	9	39	15	33	85
Compare

 

[ItalianPlatinum]

I forgot to mention that my codes (& I think Vlad's?) do not require column I to be Filtered for blanks. In fact, if you are only doing that to get the non-blank data to the other sheet then it would be better to not filter it first as it will save some time.

I should also mention

• My earlier code resulted in one row and one column of the results missing - corrected below assuming Option Base has not been set to 1.
• Formula recalculation due to filtering, column insertion etc could affect speed of code. However, the only recalculations that my codes should trigger are if there are any formulas that are triggered by changes to sheet 'Compare' A13:K13 and below

Code corrected from post 21

Sub TransferData()
  Dim vRows As Variant, vCols As Variant

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(row(#)>2,row(#),""x""),""x"")", "#", .Columns(9).Address(External:=True)))), "x", False)
      Sheets("Compare").Range("A13").Resize(UBound(vRows) + 1, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Transpose(vRows), vCols)
    End With
  End With
End Sub

Hi Vlad
Yes, that could be a problem. Need to know the size of the data as you say.
Or I could fill the vRows array looping in a similar way to you have with your 'a' array above. In testing up to about 200,000 rows the time difference between my earlier code and the one below is negligible. These codes for me are running 2 - 3 times faster than the post 23 code but that may not be relevant as it produces different results to mine - see my results below.

Sub TransferData_v2()
  Dim vCols As Variant, vRows As Variant
  Dim i As Long, k As Long

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = .Columns(9).Value
      For i = 3 To UBound(vRows)
        If Len(vRows(i, 1)) > 0 Then
          k = k + 1
          vRows(k, 1) = i
        End If
      Next i
      Sheets("Compare").Range("A13").Resize(k, UBound(vCols)).Value = Application.Index(.Cells.Value, vRows, vCols)
    End With
  End With
End Sub

My (small) sample data

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1
2	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 6	Hdr 7	Hdr 8	Hdr 9	Hdr 10	Hdr 11
3	39	52	30	37	51	66	6	71	50	41	48
4	34	57	57	25	78	59	71	31	23	70	64
5	43	81	54	51	2	81	37	81		30	62
6	79	35	74	40	57	82	35	52	16	28	32
7	5	26	20	66	45	90	77	44	18	6	72
8	32	22	16	23	19	41	49	76		37	1
9	35	40	11	44	3	14	94	68		41	88
10	38	77	14	77	16	26	45	77		6	22
11	31	13	91	54	19	37	14	11		48	90
12	82	18	56	37	89	80	71	61	60	99	95
13	81	2	35	89	10	40	56	67	77	6	87
14	43	72	23	60	52	67	28	55	71	68	60
15	3	3	83	81	93	41	59	84	12	10	47
16	36	61	74	15	80	95	20	82		15	26
17	4	57	78	33	66	76	86	45		86	6
18	88	17	97	9	88	88	17	74	33	27	39
19	26	97	80	9	39	15	33	85	23	94	16
20	22	22	26	9	57	22	95	64		1	5
21	90	91	98	86	7	48	16	62		81	7
Periodic

.. and corresponding results (using v2 code)

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
13	39	50	41	48	52	30	37	51	66	6	71
14	34	23	70	64	57	57	25	78	59	71	31
15	79	16	28	32	35	74	40	57	82	35	52
16	5	18	6	72	26	20	66	45	90	77	44
17	82	60	99	95	18	56	37	89	80	71	61
18	81	77	6	87	2	35	89	10	40	56	67
19	43	71	68	60	72	23	60	52	67	28	55
20	3	12	10	47	3	83	81	93	41	59	84
21	88	33	27	39	17	97	9	88	88	17	74
22	26	23	94	16	97	80	9	39	15	33	85
Compare

I am sorry for some reason I did not get any notifications from this thread. I downloaded the app on my phone -- since doing so I no longer recieved emails for each post. Anywho. I will test both now and see with my dataset. To confirm size of filet he max I expect this dataset to be is 10,000 rows. it should never surpass.

 

[ItalianPlatinum]

Another solution to test:

Sub TransferData1()

  Dim a() As Variant
  Dim Sh1 As Worksheet, Sh2 As Worksheet
  Dim Rng1 As Range, Rng2 As Range
  Dim i As Long, j As Long

  ' Set variables for sheets and ranges
  Set Sh1 = Sheets("Periodic")
  Set Sh2 = Sheets("Compare")
  i = Sh1.Cells(Rows.Count, "A").End(xlUp).Row ' Last data row
  Set Rng1 = Sh1.Range("A3").Resize(i - 2)
  Set Rng2 = Sh2.Range("A3").Resize(i - 2)

  ' Copy the not filtered data
  Rng2.Columns("A").Value = Rng1.Columns("A").Value
  Rng2.Columns("B:D").Value = Rng1.Columns("I:K").Value
  Rng2.Columns("E:I").Value = Rng1.Columns("B:F").Value

  ' Get filter  criteria from Rng1.Columns("I")
  a() = Rng1.Columns("I").Value
  For j = 1 To UBound(a)
    If Len(a(j, 1)) <> 0 Then a(j, 1) = 1
  Next

  ' Freeze
  Application.ScreenUpdating = False
  Application.EnableEvents = False

  ' Filter using an extra column, it's fast
  Sh2.Columns(1).Insert xlShiftToRight
  With Rng2.Offset(, -1).Resize(, 10)
    .Columns(1).Value = a()
    .Sort .Cells(1), xlAscending, Header:=xlNo
    j = .Cells(1).Offset(UBound(a)).End(xlUp).Row
    If i > j Then .Rows(j - .Row + 2 & ":" & i).ClearContents
  End With
  Sh2.Columns(1).Delete

  ' Unfreeze
  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

I had to tweak one section Set Rng2 = Sh2.Range("A3").Resize(i - 2) to Set Rng2 = Sh2.Range("A13").Resize(i - 12)

Appears to be working formatting changes ever so slightly on my destination location. When running my formulas post it isn't calculating need to investigate further but if I input the formula in the cell it does. So i know it isnt a problem with the formula.

 

[ItalianPlatinum]

I forgot to mention that my codes (& I think Vlad's?) do not require column I to be Filtered for blanks. In fact, if you are only doing that to get the non-blank data to the other sheet then it would be better to not filter it first as it will save some time.

I should also mention

• My earlier code resulted in one row and one column of the results missing - corrected below assuming Option Base has not been set to 1.
• Formula recalculation due to filtering, column insertion etc could affect speed of code. However, the only recalculations that my codes should trigger are if there are any formulas that are triggered by changes to sheet 'Compare' A13:K13 and below

Code corrected from post 21

Sub TransferData()
  Dim vRows As Variant, vCols As Variant

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(row(#)>2,row(#),""x""),""x"")", "#", .Columns(9).Address(External:=True)))), "x", False)
      Sheets("Compare").Range("A13").Resize(UBound(vRows) + 1, UBound(vCols) + 1).Value = Application.Index(.Cells.Value, Application.Transpose(vRows), vCols)
    End With
  End With
End Sub

Hi Vlad
Yes, that could be a problem. Need to know the size of the data as you say.
Or I could fill the vRows array looping in a similar way to you have with your 'a' array above. In testing up to about 200,000 rows the time difference between my earlier code and the one below is negligible. These codes for me are running 2 - 3 times faster than the post 23 code but that may not be relevant as it produces different results to mine - see my results below.

Sub TransferData_v2()
  Dim vCols As Variant, vRows As Variant
  Dim i As Long, k As Long

  vCols = Array(1, 9, 10, 11, 2, 3, 4, 5, 6, 7, 8)  '<- Columns of interest in specified order
  With Sheets("Periodic")
    With .Range("A1:K" & .Range("I" & Rows.Count).End(xlUp).Row)
      vRows = .Columns(9).Value
      For i = 3 To UBound(vRows)
        If Len(vRows(i, 1)) > 0 Then
          k = k + 1
          vRows(k, 1) = i
        End If
      Next i
      Sheets("Compare").Range("A13").Resize(k, UBound(vCols)).Value = Application.Index(.Cells.Value, vRows, vCols)
    End With
  End With
End Sub

My (small) sample data

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1
2	Hdr 1	Hdr 2	Hdr 3	Hdr 4	Hdr 5	Hdr 6	Hdr 7	Hdr 8	Hdr 9	Hdr 10	Hdr 11
3	39	52	30	37	51	66	6	71	50	41	48
4	34	57	57	25	78	59	71	31	23	70	64
5	43	81	54	51	2	81	37	81		30	62
6	79	35	74	40	57	82	35	52	16	28	32
7	5	26	20	66	45	90	77	44	18	6	72
8	32	22	16	23	19	41	49	76		37	1
9	35	40	11	44	3	14	94	68		41	88
10	38	77	14	77	16	26	45	77		6	22
11	31	13	91	54	19	37	14	11		48	90
12	82	18	56	37	89	80	71	61	60	99	95
13	81	2	35	89	10	40	56	67	77	6	87
14	43	72	23	60	52	67	28	55	71	68	60
15	3	3	83	81	93	41	59	84	12	10	47
16	36	61	74	15	80	95	20	82		15	26
17	4	57	78	33	66	76	86	45		86	6
18	88	17	97	9	88	88	17	74	33	27	39
19	26	97	80	9	39	15	33	85	23	94	16
20	22	22	26	9	57	22	95	64		1	5
21	90	91	98	86	7	48	16	62		81	7
Periodic

.. and corresponding results (using v2 code)

ItalianPlatinum_1.xlsm
	A	B	C	D	E	F	G	H	I	J	K
13	39	50	41	48	52	30	37	51	66	6	71
14	34	23	70	64	57	57	25	78	59	71	31
15	79	16	28	32	35	74	40	57	82	35	52
16	5	18	6	72	26	20	66	45	90	77	44
17	82	60	99	95	18	56	37	89	80	71	61
18	81	77	6	87	2	35	89	10	40	56	67
19	43	71	68	60	72	23	60	52	67	28	55
20	3	12	10	47	3	83	81	93	41	59	84
21	88	33	27	39	17	97	9	88	88	17	74
22	26	23	94	16	97	80	9	39	15	33	85
Compare

looks to be working. formatting issues are also mitigated. seeing same issue as vlads where some formulas arent working. if both yours causing the formulas not to work it must be something with my formulas or last row potentially.

 

[ItalianPlatinum]

You both can disregard my formula issue it was on my end. i didnt lock my formulas correctly. thank you both i am going to further stress test but right now seems to be working as i expect

 

[Peter_SSs]

max I expect this dataset to be is 10,000 rows. it should never surpass.

In that case the Application.Transpose issue that Vlad raised shouldn't be an issue so I expect that either of my codes should work (unless some other issue exists that I don't know about yet

 

[ItalianPlatinum]

In that case the Application.Transpose issue that Vlad raised shouldn't be an issue so I expect that either of my codes should work (unless some other issue exists that I don't know about yet

One slight issue just noticed the column 8 or column H is not transferring over and not sure why to the destination area of column K