VBA copy numerous cells to new sheet based on criteria

Akashwani

Well-known Member
Joined
Mar 14, 2009
Messages
2,911
Good day MrExcelers!

I have been given a Workbook to "tidy up", it's been a long time and I'm seriously struggling, so here I am!

I have a Worksheet that I CANNOT alter the layout of and that is making it difficult to find a suitable VBA code to copy the key data from the Active sheet to a "DataHistory" sheet.

The criteria will be in Column AE (Rows 3-31) in the form of a number.

The Cells I want to copy will be in these Columns and in the following order...
AE, A, F, H, J, K, L, M, O, Q, S, U, W, Y, Z, AA, AC, AD

The Cells that meet the required Criteria need to be copied to the next empty row on Sheet "DataHistory"

Example...
If AE3, AE6, AE20, AE31 have a number in, then the relevant cells on those rows need to be copied to the next empty Row on Sheet "DataHistory". So, the Data from Row3 would be copied to the next empty Row, from Row6 to the next empty Row and so on.

I hope that is clear, but I have some doubts!

Thank you for looking at this and I await some positive replies.

Ak
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try this code:

Code:
Sub Test()

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim WorkRange As Range
    Dim CopySize As Long
    Dim CopyArray() As Variant
    Dim Cell As Range
    
    With ActiveWorkbook
        Set Sht1 = .ActiveSheet
        Set Sht2 = .Worksheets("DataHistory")
    End With
    
    Set WorkRange = Sht1.Range("AE3:AE31")
    
    CopySize = 0
    For Each Cell In WorkRange
        With Cell
            If IsNumeric(.Value) Then
                CopySize = CopySize + 1
                ReDim Preserve CopyArray(1 To 18, 1 To CopySize)
                CopyArray(1, CopySize) = .Offset(0, 0).Value
                CopyArray(2, CopySize) = .Offset(0, -30).Value
                CopyArray(3, CopySize) = .Offset(0, -25).Value
                CopyArray(4, CopySize) = .Offset(0, -23).Value
                CopyArray(5, CopySize) = .Offset(0, -21).Value
                CopyArray(6, CopySize) = .Offset(0, -20).Value
                CopyArray(7, CopySize) = .Offset(0, -19).Value
                CopyArray(8, CopySize) = .Offset(0, -18).Value
                CopyArray(9, CopySize) = .Offset(0, -16).Value
                CopyArray(10, CopySize) = .Offset(0, -14).Value
                CopyArray(11, CopySize) = .Offset(0, -12).Value
                CopyArray(12, CopySize) = .Offset(0, -10).Value
                CopyArray(13, CopySize) = .Offset(0, -8).Value
                CopyArray(14, CopySize) = .Offset(0, -6).Value
                CopyArray(15, CopySize) = .Offset(0, -5).Value
                CopyArray(16, CopySize) = .Offset(0, -4).Value
                CopyArray(17, CopySize) = .Offset(0, -2).Value
                CopyArray(18, CopySize) = .Offset(0, -1).Value
            End If
        End With
    Next Cell
    
    Sht2.Range("A1").Resize(CopySize, 18) = Application.Transpose(CopyArray)

End Sub
 
Upvote 0
Hi G, thanks for the reply.

I'm sorry to report that your code doesn't work as requested.
It somehow only copies over Rows 25:26 (These DO NOT have a number in Column AE), or it copies the data onto the same Row on Sheet DataHistory and also copies data that does not meet the criteria.

Ak
 
Upvote 0
*Sample Data*
Excel Workbook
AEFHJKLMOQSUWYZAAACADAE
7U09575860126.42140132.940815490.301.19%8.60-116.790.163-7.06152.170.5-56.0719/08/14
8U095762561326.53280343.67408134116.62-1.40%8.50395.390.10963.674135.870.5-145.7119/08/14
10U096593403666.99640646.347605189.2104.222.64%2.1056.670.1886.3476184.212.543.3419/08/14
11U098752496449.28490504.19601020191.690.50%4.80-195.460.19614.196200.002.5-263.6019/08/14
13U0991873021314.3613701477.5040420295.947.18%11.73-652.660.188107.504187.502.5-1,913.6819/08/14
279120493444.8346114.71500122.597.4660.82%6.80-7.940.04968.71548.000.3-475.2019/08/14
28423932221124.38128316.326200142.297.1760.62%6.80-24.640.058188.32656.000.5-1,305.2619/08/14
294251356057.1258108.380019398.4847.15%7.52-6.620.10450.38102.000.3-385.4819/08/14
30425102834201.21205403.494800142.298.1550.07%6.80-25.740.072198.49571.000.5-1,375.5119/08/14
3142392119767.0368170.811900142.798.5860.76%2.23-2.160.057102.81256.000.0-231.1219/08/14
19-08-14



*Results*

Excel Workbook
BCDEGMNPQRS
1
2166222883.5762920000.1756710.0029118.50.00
3****TAILS
4
DataHistory
 
Upvote 0
*Expected Results*

Excel Workbook
ABCDEFGHIJKLMNOPQRS
1Header1Header2Header3Header4Header5Header6Header7Header8Header9Header10Header11Header12Header13Header14Header15Header16Header17Header18
219/08/2014U09575860126.42140132.940815490.30.0118588.6-116.7880.162791-7.06152.17390.5-56.07
319/08/2014U095762561326.5275280343.67408134116.617-0.013958.498395.39070.10933263.674135.86960.5-145.71
419/08/2014U096593403666.988640646.347605189.2104.21690.0263712.156.67480.1880696.3476184.21052.543.34
519/08/2014U098752496449.28490504.19601020191.68980.0049754.8-195.4560.19631414.1962002.5-263.60
619/08/2014U0991873021314.3613701477.5040420295.938690.07178211.73-652.6570.18762107.504187.52.5-1,913.68
719/08/20149120493444.83246114.71500122.597.460870.6081636.8-7.94240.04925168.715480.3-475.20
819/08/2014423932221124.376128316.326200142.297.168750.6061886.8-24.64320.057632188.3262560.5-1,305.26
919/08/20144251356057.1258108.380019398.482760.4715037.52-6.61760.10357150.381020.3-385.48
1019/08/2014425102834201.214205403.494800142.298.153170.5007036.8-25.74480.072336198.4948710.5-1,375.51
1119/08/201442392119767.03268170.811900142.798.576470.6075682.227-2.155740.056809102.8119560-231.12
12
DataHistory


Ak
 
Upvote 0
Try changing this line...

From:

If IsNumeric(.Value) Then

To:

If IsDate(.Value) Then
 
Last edited:
Upvote 0
Hi G,

Yes, that works, I changed this...

Sht2.Range("A1")

To

Sht2.Range("A2")

So that it doesn't copy over my Header row, BUT, when I run the code again, the new data doesn't get copied to the next empty row, which based on the example above, would be Row12, it gets copied to row2!

Any thoughts?

Thanks for your continued help with this.

Ak
 
Upvote 0
Hi Alan,

I'm just about out of time here, but YES, your sample data looks spot on! :)

Thanks for taking a look at this for me, much appreciated.

Ak
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top