copy a group of cells using relative references in vba

[rad_melb]

I need to write a macro that travels down a column and once it finds a certain value it copies the next 48 cells and pastes in another sheet. this repeats until an empty cell is reached.

Is there are a command to copy all 48 cells together (remember it has to be a relative reference)? If I knew the cells to copy I could just do for e.g

Range("D2:D49").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
ActiveSheet.Paste

but I dont know the cells to copy until a certain condition is met

 

[rad_melb]

I guess I am looking for some version of this:

Range(Selection, Selection.End(xlDown)).Select

that selects and copies the next 48 cells, from the active cell, in a column,
as opposed to the line above which selects all cells between activecell and end of column

 

[stanleydgromjr]

rad_melb,

What is the sheetname you are searching in?

What is the column in this sheet that you are searching in?

What is the value you are searching for?

Have a great day,
Stan

 

[rad_melb]

hey stan

i am searching in sheet 'prices 06-07'

I am searching column G which contains the excel formula weekday(). When I find that the excel function weekday() returns 2 (i.e. a monday) then I need to copy a range of 48 cells in column D. This is 48 half hourly prices associated with a monday. I then need to paste that in a newsheet in range("A1:A48").

This process has to repeated using a loop which exits when column G becomes empty. The second time a range of 48 cells is copied it needs to be pasted in range (b1:b48). The third time a range of 48 cells is copied it needs to be pasted in range (c1:c48) and so on

Cheers
Rad

 

[stanleydgromjr]

Rad,

Here you go.

Please TEST this FIRST in a COPY of your workbook.

Press and hold down the 'ALT' key, and press the 'F11' key.

Insert a Module in your VBAProject, Microsoft Excel Objects

Copy the below code, and paste it into the Module1.

Option Explicit
Sub MoveMondaysRowPlus47RowsToNewSheet()
'
    Dim strNewSheetName As String
    Dim lngDataLastRow As Long
    Dim lngDataLoopCounter As Long
    Dim lngNewSheetColumnNumber As Long

    Sheets("prices 06-07").Select
    Range("A1").Select
    Application.ScreenUpdating = False
    Sheets.Add
    strNewSheetName = ActiveSheet.Name
    Sheets(strNewSheetName).Move After:=Sheets("prices 06-07")
    Sheets("prices 06-07").Select
    lngDataLastRow = Range("G" & Rows.Count).End(xlUp).Row + 1
    lngNewSheetColumnNumber = 1
    For lngDataLoopCounter = 2 To lngDataLastRow Step 1
        If Cells(lngDataLoopCounter, "G").Value = 2 Then
            Sheets("prices 06-07").Range("D" & lngDataLoopCounter & ":D" & lngDataLoopCounter + 47).Copy _
                Sheets(strNewSheetName).Cells(1, lngNewSheetColumnNumber)
            lngNewSheetColumnNumber = lngNewSheetColumnNumber + 1
            lngDataLoopCounter = lngDataLoopCounter + 47
        End If
    Next lngDataLoopCounter
    Application.ScreenUpdating = True
End Sub

Please TEST this FIRST in a COPY of your workbook.

Then run the 'MoveMondaysRowPlus47RowsToNewSheet' macro.

Have a great day,
Stan