Macro to copy rows with data from one sheet to another...

[LittleAngel]

I have 2 worksheets. I'd like to have a macro (I am new to macros) that does the following:

- Starts in Sheet 1 in a cell that you pick (usually row 7 column A)
- Checks that row if it's blank
- If it's not blank, copy the row to sheet 2 (row 1)
- if it is blank, check the next row for data.
- If the next row has data, copy that data after the last copied data in sheet 2 (row 2)
- if it's blank, quit.
- Keep checking for blank rows and copying into sheet two until it comes to two consecutive rows that are blank.

Thank you!

 

[pink]

It's in date format: 01/01/1996 And yes, that's what I want it to do. Show only the row data and dates for dates between 01/01/1996 and 31/12/1998.

Thanks.

 

[agihcam]

try;

Sub test()
Dim x As Long
Dim beg1, en1 As Date
Sheets(1).Activate
beg1 = InputBox("Enter beginning date", , "01/01/1996")
en1 = InputBox("Enter end date", , "31/12/1998")
Application.ScreenUpdating = False
Range("A1:H2000").Copy
Sheets("Sheet2").Activate
        Range("a1").Select
        ActiveSheet.Paste
For x = Range("A65536").End(xlUp).Row To 1 Step -1
If Range("A" & x) < CDate(beg1) Or Range("A" & x) > CDate(en1) Then Rows(x).Delete
Next x
Application.ScreenUpdating = True
End Sub

 

[pink]

Thanks. I tried the code, but it's not working. Instead of copying the data from column H when the date in column A is between 01/01/1996 and 31/12/1998 it's not copying anything, but just highliting cells A1:H2000 on Sheet 2.

 

[Yellow[GummiBear]]

sorry i have a few questions regarding the code..

how do i:

- edit the StartRow to hardcode it to the Row & Column pre-defined

I think an answer is:

Change:
StartRow = _
Application.InputBox(Prompt:="Select any cell in your beginning row", Type:=8).Row
If Not IsNumeric(StartRow) Then Exit Sub
Err.Clear
On Error GoTo 0

To:
StartRow = Range("A1").Row 'Make "A1" whatever you want

I've also got a few questions myself though (related to the ones already asked...

I would like to copy the rows associated with all cells in Column AI with a value > 0. Note, that the 0's are mixed in with numbers that are > 0 so I can't have the macro end after it reaches a 0.

For example the macro written by Jay seems to end once it finds 2 consecutive empty rows assuming there are no more populated rows beneath it. I would like my macro to only end once it reaches the bottom of a defined range.

I would appreciate a few suggestions about areas of the code that can be modified to meet my needs so that I can still experience the challenge of getting the macro to work the way I'd like.

Thanks in advance!

 

[Yellow[GummiBear]]

To add a little more to this project I have some other things that need pasting into the new sheet...

I intend to have my whole sheet look like this when it's finished:
TOP: Rows 1-9 that are always the same 8 rows - just with different values

MIDDLE: x number of rows that is determined by the number of rows that have a value in AI > 0

BOTTOM: Rows 108-138 that are always the same - just with different values

Right now I've mainly been concentrating on getting the ranges to copy/paste in the correct places. Eventually I want to make sure that the rows I have hidden remain hidden after the paste and that I only paste the values.

Here's what I've got so far:

Sub PrintButton_Click()

    Dim wks1 As Worksheet, wks2 As Worksheet
    Dim LastRow As Long, StartRow As Long, x As Long
    Dim rng1 As Range, rng2 As Range, FinishRow As Long
    Dim fn As WorksheetFunction
    Dim top As Range, btm As Range '************
    
    Set fn = Application.WorksheetFunction
    Set wks1 = ThisWorkbook.ActiveSheet '*********Seems to work
    Set wks2 = ThisWorkbook.Sheets("Print Sheet")
    
    wks2.Cells.ClearContents

' =============== Sets the top and bottom ranges ============
    Set top = wks1.Range("A1:AJ9")
'    Set top = .Range(.Cells(1, 1), .Cells(36, 9))
    Set btm = wks1.Range("A99:AJ138")
'    Set btm = .Range(.Cells(1, 99), .Cells(36, 138))
    
' =============== Tries to copy/paste the ranges ============
' =============== from wks1 to wks2              ============
    With wks1
    On Error Resume Next
        top.Copy wks2.Range("A1")
    End With
    
' =============== Jay's Code slightly modified ==============
    With wks1
        On Error Resume Next

        StartRow = Range("A10").Row

        LastRow = Range("A98").Row
    '    LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        FinishRow = LastRow
        For x = StartRow To LastRow
            If fn.CountA(.Rows(x)) = 0 And fn.CountA(.Rows(x + 1)) = 0 Then
                FinishRow = fn.Max(StartRow, x - 1) 'Last full row
                Exit For
            End If
        Next x
        Set rng1 = .Range(.Cells(StartRow, 1), .Cells(FinishRow, 256))
    
        rng1.Copy wks2.Cells(Rows.Count, 1).End(xlUp).Offset(1)

    End With

    With wks2
        LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        For x = LastRow To 1 Step -1
            If fn.CountA(.Rows(x)) = 0 Then .Rows(x).Delete shift:=xlUp
        Next x
    End With

' =============== Tries to copy/paste the bottom ============
' =============== from wks1 to wks2              ============

    With wks1
    On Error Resume Next
        btm.Copy wks2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End With

End Sub

When this is all said and done I'd like to set it up to print the resulting sheet on 1 page landscape style. I'm sure I could do a forum search to find this answer but I haven't crossed that bridge yet.

 

[Yellow[GummiBear]]

I hate to be annoying and bump but the threads get buried so fast on this forum...

Does anyone have any suggestions I could try?

Thanks!

 

[Jay Petrulis]

Try the following for the page setup

    With wks2
        With .PageSetup
            .Orientation = xlLandscape
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
    End With

I haven't reread the thread, so I can't offer anything else at the moment.

 

[Yellow[GummiBear]]

Thanks Jay. I just added a line of code for the PrintArea and it worked like a charm.

Have you had any luck with anything else yet?... unfortunately I'm still struggling.

 

[Yellow[GummiBear]]

hmmm actually it isn't working like a charm... I didn't pay close enough attention to the sheet it was printing out. It was actually printing from the source page and not the summary page for some reason.

Now it's printing out the correct sheet but it isn't printing it out on the correct dimensions (it's landscape but it's 8 pages long instead of 1)

Here's what I've got:

    With wks2
        On Error Resume Next
        .Activate
        endrow = wks2.Range("A65536").End(xlUp).Row
        endcol = wks2.Range("iv1").End(xlToLeft).Column
        With .PageSetup
            .PrintArea = ""
            .Orientation = xlLandscape
            .PrintArea = Range(Cells(1, 1), Cells(endrow, endcol))
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        .Range(Cells(1, 1), Cells(endrow, endcol)).Select
        Application.Dialogs(xlDialogPrint).Show
'        .PrintOut ' Copies:=1, Collate:=True
    End With

I'm also still having trouble with the first part of my question. I haven't been able to copy only the rows where column AI>0 and whenever I copy/paste a series of rows all the hidden rows are pasted in non-hidden form making the sheet very messy.

Thanks again in advance for your help

 

[Yellow[GummiBear]]

can.... not...... resist.................. any................... longer................. bump