Pared down Data

[Nando01]

Two months ago, WATERSEV (Valued Forum Contributor) provided the perfect solution to me problem.

REF: http://www.excelforum.com/excel-prog...-plotting.html

The need has changed, and now I need to perform the same task, but instead of doing it to all the sheets of the active workbook and creating a new workbook for the pared down data, I need to do it to three specific sheets of the active workbook, which may have several more worksheets, and write the pared down data on three new sheets in the same active workbook.

In other words.

Before: All sheets > pared down data > new workbook, new sheets
Now: Sheets Test1, Test2, and Test3 > pared down to new sheets > Test1B, Test2B, Test3B in the same active workbook.

Thanks!

Alex

[Nando01]

I tried a couple of things but no success, so I still need help.

To retiterate -
The paring down works fine (keeping every 25th row), but now I need the pared down data in new worksheets of the same (active) workbook instead of a new workbook.

Thx!
Alex

[watersev]

hi, Nando01, please check attachment, run code "test". The data is supposed to start from A1 and down.

[Nando01]

watersev,

I tried to open, download, save, copy, etc. the attached link but always came up with a series of errors, as follows:

Small Window said:
Microsoft Visual Basic - FILE NOT FOUND
[OK]
(This window appeared twice in succession.)

Then,
Excel found unreadable contents in ‘copyTrimDown(1)_new(1).xls’
Do you want to recover the contents of this workbook? If you trust the source of the notebook, click yes.
[>> Yes]

Lastly,
Repair to ‘copyTrimDown(1)_new(1).xls’
Excel was able to open the file by repairing or removing the unreadable content.
Lost Visual Basic Project

And what was left was a workbook with three sheets, Test1, Test2, and Test3 with just numbers.

The company changed my computer about two weeks ago, and I don’t know what settings they have on this one. I tried it on another computer and the error at that PC was ‘error 265’, and the end result was the same as above.

Perhaps if you list the code I could just enter it manually?

Sorry about all this extra trouble.

Thx!

Alex

[watersev]

hi there, I've downloaded file without any troubles. I've reposted same file in xls and xlsm format.

The workbook contains three sheets: Test1, Test2, Test3 (you need to change them in the code for different sheet names). The data starts from A1 on all sheets and down. Three new sheets: Test1B, Test2B, Test3B created with 25th data from each sheet Column A.

Code inside:

Option Explicit
Sub test()

Dim main As Workbook, sh_arr, nm, data, colcount As Long, rowscount As Long, result, i As Long, _
n As Long, j As Long, err_str As String

Application.ScreenUpdating = 0

Set main = ActiveWorkbook
sh_arr = Split("Test1,Test2,Test3", ",")

On Error Resume Next

For Each nm In sh_arr

    If Err.Number = 0 Then
        
        data = main.Sheets(nm).Range("a1").CurrentRegion
        
        colcount = UBound(data, 2)
        rowscount = UBound(data)
        
        ReDim result(1 To rowscount, 1 To colcount)

        For i = 25 To rowscount Step 25
            j = j + 1
            For n = 1 To colcount
                result(j, n) = data(i, n)
            Next
        Next

        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Range("a1").Resize(j, colcount) = result
            .Name = nm & "B"
        End With
        
        ReDim result(1 To rowscount, 1 To colcount)
        j = 0
        
    Else
    
        err_str = err_str & nm & Chr(10)
        Err.Clear
            
    End If

Next

Application.ScreenUpdating = 1

If err_str <> "" Then
    MsgBox "Sheets: " & Chr(10) & Chr(10) & err_str & Chr(10) & " were not found and thus not processed.", vbCritical
Else
    MsgBox "All three sheets have been successfully processed", vbInformation
End If

End Sub

Hope this helps.

[Nando01]

Watersev,
I have been on vacation, and just accessed you reply from home.
I was able to open the macro, but I do not have the data here. I will try tomorrow when I am back at work and let you know.
Thanks!
Alex

[Nando01]

watersev,

That worked fine! I still couldn't download it here at work, but I got around that hurdle, and it runs fine!

Thank You So Much!

Alex

[Nando01]

watersev,

That worked great! (I still had to copy and paste it, but no problem with that, and it runs fine.)

Thank You Very Much!

Alex