Vba to find multiple specific values and copy and paste them to different locations

[sequence]

Hello.
I am trying to reorganise some data. I have a list of numbers in column A. I want my code to look in column A for all the rows with "350" and copy and paste those rows to U4. I want it to do this for all the different numbers. There is over 100 of them.

This is what i have so far but it just takes so long. If there is a more efficient way of doing this i would appreciate the help. Thank you.

' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 4 To FinalRow
DoEvents


' Decide if to copy based on column A
ThisValue = Cells(x, 1).Value
If ThisValue = "350" Then


Cells(x, 1).Resize(1, 17).Copy
nextRow = Cells(Rows.Count, "U").End(xlUp).Row + 2
Cells(nextRow, "U").Select
ActiveSheet.Paste
DoEvents
ElseIf ThisValue = "400" Then


Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "BA").End(xlUp).Row + 2
Cells(nextRow, "BA").Select
ActiveSheet.Paste


ElseIf ThisValue = ("13717") Then




Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "CG").End(xlUp).Row + 2
Cells(nextRow, "CG").Select
ActiveSheet.Paste




ElseIf ThisValue = ("16730") Then




Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "DM").End(xlUp).Row + 2
Cells(nextRow, "DM").Select
ActiveSheet.Paste




ElseIf ThisValue = ("35723") Then


Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "ES").End(xlUp).Row + 2
Cells(nextRow, "ES").Select
ActiveSheet.Paste




ElseIf ThisValue = ("54885") Then
Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "FY").End(xlUp).Row + 2
Cells(nextRow, "FY").Select
ActiveSheet.Paste




ElseIf ThisValue = ("55677") Then
Cells(x, 1).Resize(1, 17).Copy


nextRow = Cells(Rows.Count, "HE").End(xlUp).Row + 2
Cells(nextRow, "HE").Select
ActiveSheet.Paste


Etc, Etc for over 100 different numbers

 

[offthelip]

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
(actually this I break this rule slight because I write back the array one every cycle, but I have got to write the data out at some point.) The point about this code it reads the worksheet just twice, one to determine the finalrow and the second to load all the data into memory It then writes to the worksheet one every loop so just 100 writes for 100 numbers.
This code should take less than a second for over 100 numbers in the “mapping” array
Note the mapping array is a way of controllling the program using data rather than hard coded if statements. It should obvious how it works. I have set a maxmap to allow you to define how many number you want.

Sub movedata()
' double quotes character
tt = Chr(34)
Dim mapping(1 To 100, 1 To 2) As Variant
mapping(1, 1) = 350
mapping(1, 2) = "U"
mapping(2, 1) = 400
mapping(2, 2) = "BA"
mapping(3, 1) = 13717
mapping(3, 2) = "CG"
mapping(4, 1) = 16730
mapping(4, 2) = "DM"


maxmap = 4
Dim outarr() As Variant






finalrow = Cells(Rows.Count, 1).End(xlUp).Row
'define output array
ReDim outarr(1 To finalrow, 1 To 17)
'load all the data into a variant array
inarr = Range(Cells(1, 1), Cells(finalrow, 18))


'Loop through the numbers to search for
For m = 1 To maxmap


' reinitialise the output array
indi = 1
For kk = 1 To finalrow
 For jj = 1 To 17
  outarr(kk, jj) = ""
 Next jj
Next kk


' Loop through each row
For x = 4 To finalrow
  If inarr(x, 1) = mapping(m, 1) Then
  ' if number equal mapping copy the row to output array
    For jj = 1 To 17
     outarr(indi, jj) = inarr(x, jj)
    Next jj
    indi = indi + 1
  End If
Next x
 ' copy output array to correct column
 colad = mapping(m, 2) & "1:" & mapping(m, 2) & "1"
Range(colad).Resize(finalrow, 17) = outarr




Next m


End Sub

 

[sequence]

Thank you so much for this. it works way quicker. i have another issue when trying to do an iF and statement. At the minute using
this formula =IF(AND(DT17>" ",$EC17="O"),1," ") if it sees a value greater than blank in DT17 and it sees a O in EC17 it returns the value one. I want to add into it that if it sees a value greater than blank in DT17 and the letter I in EC17 that it returns a (-1). Can you help me with this please? Thank you

 

[offthelip]

try this:

=IF($DT17>" ",IF($EC17="O",1,IF($EC17="I",-1," "))," ")

 

[sequence]

try this:

=IF($DT17>" ",IF($EC17="O",1,IF($EC17="I",-1," "))," ")

Thank you for this but it does not do what im looking for. It just gives blanks for all the cells no matter what. I need the cell to be 1 if DT17 has any value and EC17 is O. If a row has a value in DT but has a I in EC17 then i need the cell to be -1. Right now its just giving me a blank cell.

 

[offthelip]

if it sees a value greater than blank in DT17

You quite clearly stated that this was your requirement so I followed what you asked for
Your original equations had :
DT17> " "

which I thought was a bit strange but it does work if you put a letter in the cell. If you just put a number then this logic is "FALSE" and you get a blank
I think what you might want is to check that DT17 is NOT blank,
so try

=IF($DT17<>"",IF($EC17="O",1,IF($EC17="I",-1," "))," ")

 

[sequence]

You quite clearly stated that this was your requirement so I followed what you asked for
Your original equations had :
DT17> " "

which I thought was a bit strange but it does work if you put a letter in the cell. If you just put a number then this logic is "FALSE" and you get a blank
I think what you might want is to check that DT17 is NOT blank,
so try

=IF($DT17<>"",IF($EC17="O",1,IF($EC17="I",-1," "))," ")

Yes the problem was I had the cell formatted wrong but it is working properly now. Thank you!