Selective copying based on criteria

default_name

Board Regular
Joined
May 16, 2018
Messages
137
Office Version
2016
Platform
Windows, MacOS
Hi guys!

I have kind of a complex question.
It all starts with a very large spreadsheet (let's call it 'raw data'). It has many columns of information (A:GD).
Much of this data is pretty useless to me, to be honest.
But there are a few pieces of information that I want to extract (if the row meets a certain criteria) onto a new sheet (let's call it 'reduced data').
The criteria is date (found in column AR).

If the date in column AR comes after 'today's date minus two years' [example: today is May 21, 2020. if the date is after May 21, 2018] then I want to grab relevant data from certain columns in that row and paste it into the new sheet.

Fictional Data Example:

The following represents the 'raw data' table (including some unwanted data). I skipped a few columns (shown with the '....') just to show the scale of the data.
The raw data table also changes/varies in number of rows from time to time.
If I have this data, then I would want to look at the cell in column AR. If the date comes after 'today's date minus two years' then I want to copy over desired data from that row.
If it comes before that date, then the data is ignored and the VBA moves on to check the next row.
ABC....ARAS...GBGCGD
2134675448-898-5641Y
....​
2/21/2005QGC
....​
UPLA5451388Blue
4041384357-8243-863Y
....​
5/15/2019QRP
....​
USLS1545348Blue
5135454319-999-5621X
....​
8/8/2023QGC
....​
UPLC1534688Green
45135451355-43354-4Y
....​
5/14/2020QPA
....​
URST6435412Red
45134545466-4548-87X
....​
5/18/2018QHU
....​
UGJR1513334Red
45156737848-000-264C
....​
6/20/2024JGKS
....​
UJGL1324858Green

The following represents the new 'reduced data' sheet where the important data is pasted.
Notice how data from only a few rows were copied over.
Also notice that the data was copied over in a particular column order.

A (copied from GD)B (copied from AS)C (copied from AR)D (copied from A)
BlueQRP5/15/2019404138435
GreenQGC8/8/2023513545431
RedQPA5/14/2020451354513
GreenJGKS6/20/2024451567378

I am hoping to achieve this routine via VBA code. I am having issues, though, because the table length (number of rows) can vary/change too.
I hope this makes sense.
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,233
Office Version
2007
Platform
Windows
Try this:

VBA Code:
Sub ReducedData()
  Dim a As Variant, b As Variant, nDate As Date
  Dim i As Long, j As Long
  
  a = Sheets("raw data").Range("A2:GD" & Sheets("raw data").Range("AR" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a), 1 To 4)
  nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
  For i = 1 To UBound(a)
    If a(i, 44) > nDate Then
      j = j + 1
      b(j, 1) = a(i, 186)
      b(j, 2) = a(i, 45)
      b(j, 3) = a(i, 44)
      b(j, 4) = a(i, 1)
    End If
  Next
  Sheets("reduced data").Range("A2").Resize(j, 4).Value = b
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,233
Office Version
2007
Platform
Windows
I'm glad to help you. Thanks for the feedback.
 

default_name

Board Regular
Joined
May 16, 2018
Messages
137
Office Version
2016
Platform
Windows, MacOS
I want to incorporate the routine with multiple raw data sheets.

Basically, I want to paste into the same 'reduced data' sheet (there is a 'raw data2' sheet in the same workbook, with similar information).
How would I run the same type of routine on 'raw data2' but to have the VBA paste that data after/at the end/bottom of the original 'raw data' information?

Here is my attempt, but it doesn't really work.
VBA Code:
Sub ReducedData()
Dim a As Variant, b As Variant, nDate As Date
Dim i As Long, j As Long

a = Sheets("raw data").Range("A2:GD" & Sheets("raw data").Range("AR" & Rows.Count).End(3).Row).Value2
ReDim c(1 To UBound(a), 1 To 4)
nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
For i = 1 To UBound(a)
If a(i, 44) > nDate Then
j = j + 1
c(j, 1) = a(i, 186)
c(j, 2) = a(i, 45)
c(j, 3) = a(i, 44)
c(j, 4) = a(i, 1)
End If
Next
Sheets("reduced data").Range("A2").Resize(j, 4).Value =c

b = Sheets("raw data2").Range("A2:GD" & Sheets("raw data2").Range("AR" & Rows.Count).End(3).Row).Value2
ReDim c(1 To UBound(a), 1 To 4)
nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
For i = 1 To UBound(a)
If a(i, 44) > nDate Then
j = (j + 1)
c(j, 1) = a(i, 186)
c(j, 2) = a(i, 45)
c(j, 3) = a(i, 44)
c(j, 4) = a(i, 1)
End If
Next
Sheets("reduced data").Range.End(xlUp).Row("A2").Resize(j, 4).Value = c

End Sub
Thanks again for all your help!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,233
Office Version
2007
Platform
Windows
Here you can put the raw sheets:
shs = Array("raw data", "raw data2")


Try this:

VBA Code:
Sub ReducedData()
  Dim a As Variant, b As Variant, nDate As Date
  Dim i As Long, j As Long, shs As Variant, s As Variant
  Dim sh As Worksheet
  
  Set sh = Sheets("reduced data")
  shs = Array("raw data", "raw data2")
  sh.Rows("2:" & Rows.Count).ClearContents
  For s = 0 To UBound(shs)
    j = 1
    a = Sheets(shs(s)).Range("A2:GD" & Sheets(shs(s)).Range("AR" & Rows.Count).End(3).Row).Value2
    ReDim b(1 To UBound(a), 1 To 4)
    nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
    For i = 1 To UBound(a)
      If a(i, 44) > nDate Then
        b(j, 1) = a(i, 186)
        b(j, 2) = a(i, 45)
        b(j, 3) = a(i, 44)
        b(j, 4) = a(i, 1)
        j = j + 1
      End If
    Next
    sh.Range("A" & Rows.Count).End(3)(2).Resize(j, 4).Value = b
    Erase a, b
  Next
End Sub
 

default_name

Board Regular
Joined
May 16, 2018
Messages
137
Office Version
2016
Platform
Windows, MacOS
Hey Dante,

Thanks for your help and patience on this! I really do appreciate it!

Your code works just as I mentioned it. The problem is, I erred in my most recent comment.
Both raw data sheets have similar information, yes.
But both of the spreadsheets have the data organized in different columns.

I just realized that as I was trying to implement your most recent code. My previous post should have looked like this:
The column numbers in each of the routines needed to be different:

c(j, 1) = a(i, 186)
c(j, 2) = a(i, 45)
c(j, 3) = a(i, 44)
c(j, 4) = a(i, 1)
for pulling from raw data

and

c(j, 1) = a(i, 18)
c(j, 2) = a(i, 38)
c(j, 3) = a(i, 40)
c(j, 4) = a(i, 42)
for pulling from raw data2

VBA Code:
Sub ReducedData()
Dim a As Variant, b As Variant, nDate As Date
Dim i As Long, j As Long

a = Sheets("raw data").Range("A2:GD" & Sheets("raw data").Range("AR" & Rows.Count).End(3).Row).Value2
ReDim c(1 To UBound(a), 1 To 4)
nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
For i = 1 To UBound(a)
If a(i, 44) > nDate Then
j = j + 1
c(j, 1) = a(i, 186)
c(j, 2) = a(i, 45)
c(j, 3) = a(i, 44)
c(j, 4) = a(i, 1)
End If
Next
Sheets("reduced data").Range("A2").Resize(j, 4).Value =c

b = Sheets("raw data2").Range("A2:GD" & Sheets("raw data2").Range("AR" & Rows.Count).End(3).Row).Value2
ReDim c(1 To UBound(a), 1 To 4)
nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
For i = 1 To UBound(a)
If a(i, 44) > nDate Then
j = (j + 1)
c(j, 1) = a(i, 18)
c(j, 2) = a(i, 38)
c(j, 3) = a(i, 40)
c(j, 4) = a(i, 42)
End If
Next
Sheets("reduced data").Range.End(xlUp).Row("A2").Resize(j, 4).Value = c

End Sub
Thanks again for your help. You are the best!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,233
Office Version
2007
Platform
Windows
If a(i, 44) > nDate Then
j = (j + 1)
c(j, 1) = a(i, 18)
c(j, 2) = a(i, 38)
c(j, 3) = a(i, 40)
c(j, 4) = a(i, 42)
for pulling from raw data2
In rawdata2 in which column do you have the date?
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,233
Office Version
2007
Platform
Windows
In that case:

VBA Code:
Sub ReducedData()
  Dim a As Variant, nDate As Date
  Dim i As Long, j As Long, lr As Long
  Dim sh As Worksheet
  
  nDate = DateSerial(Year(Date) - 2, Month(Date), Day(Date))
  Set sh = Sheets("reduced data")
  sh.Rows("2:" & Rows.Count).ClearContents
  
  a = Sheets("raw data").Range("A2:GD" & Sheets("raw data").Range("AR" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a), 1 To 4)
  For i = 1 To UBound(a)
    If a(i, 44) > nDate Then
      j = j + 1
      c(j, 1) = a(i, 186)
      c(j, 2) = a(i, 45)
      c(j, 3) = a(i, 44)
      c(j, 4) = a(i, 1)
    End If
  Next
  sh.Range("A2").Resize(j, 4).Value = c
  
  j = 0
  Erase a, c
  a = Sheets("raw data2").Range("A2:GD" & Sheets("raw data2").Range("AR" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a), 1 To 4)
  For i = 1 To UBound(a)
    If a(i, 40) > nDate Then
      j = j + 1
      c(j, 1) = a(i, 18)
      c(j, 2) = a(i, 38)
      c(j, 3) = a(i, 40)
      c(j, 4) = a(i, 42)
    End If
  Next
  
  lr = sh.Range("C" & Rows.Count).End(3).Row + 1
  sh.Range("A" & lr).Resize(j, 4).Value = c
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,102,907
Messages
5,489,650
Members
407,703
Latest member
Chibuzo

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top