copying a range

Hello


I'm trying to write code that will find a cell based on fixed values (can be coded in the macro) and then copy the values of that cell and the 3 cells below to another column say C. In the end it will need to loop and consequently extract multiple sets of cells to copy to the new columns


I can find and copy the first cell but i'm not able to copy the 4 cells together using offset.
Main question then is how do I find and copy a range of 4 cells?

Unfortunately i don't have the code here with me, so i can paste what i got/tried sofar. Will do that tomorrow or later this day. But hopefully someone can hint me in right direction.


Thanks Very Much

Science Boy

Hello Science Boy,

Here is how to 4 rows of cells based on the first cell found to a new destination. This macro takes 2 arguments: the source cell (the one Find returned), and the new cell location. This allows the macro to be used later in a loop.

Sub CopyRows(Src_Cell As Range Dst_Cell As Range)

  Dim Rng As Range
    Set Rng = Src_Cell.Resize(4, 1)
    Rng.Copy Destination:=Dst_Cell

End Sub

Using the Macro

'This will copy A1:A4 to B1:B4  on the same worksheet
  CopyRows Range("A1"), Range("B1")

'This will copy A1:A4 of the active sheet to B1:B4 on Sheet 3
  CopyRows Range("A1"), Worksheets("Sheet3").Range("B1")

Sincerely,
Leith Ross

Thanks Leith,

Now lets see if I can make this work. If not i'll be back

Leith, or someone else

-if this should be in a seperate topic let me know and i'll start one-

I've used the code and used it in the macro below. Its a query to retrieve traffic information and then copy selected roads to another part of the sheet. However I need a way to make this loop as there will be more than 1 notification of the same road when it is very busy and i like to see all of them. I will probably be looking at a max of five individual roads, like A1. A12, A14. (not like A1, A2, A3). I've coded for 2 now but i suppose 2 or 5 shouldn't be much of a difference with regard to method of coding.

I also had to use the on error resume next because if it doesn't find anything the macro fails.

Question: How to loop this properly?
Question: Is this a "proper" way and/or can i take shortcuts somewhere?

Sub query()

   Dim LastRow As Long

On Error Resume Next

'brings traffic jam data from web to excel
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.nu.nl/pda_sectie.jsp?n=236&c=75", Destination:=Range("A1"))
        .Name = "pda_sectie.jsp?n=236&c=75"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "5"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
  Columns("B:f").Select
  Selection.ClearContents
  
'finds road
Columns("A:A").Select
Selection.Find(What:="File: A10 ", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
 
'finds last row in column C
    With ActiveSheet
   LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
   End With
  
CopyRows ActiveCell, Cells(LastRow, 3).Offset(2, 0)
ActiveCell.ClearContents


'next road
Columns("A:A").Select
Selection.Find(What:="File: A35 ", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
 
    
   With ActiveSheet
   LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
   End With
  
CopyRows ActiveCell, Cells(LastRow, 3).Offset(2, 0)
ActiveCell.ClearContents

    
    End Sub

Hello Science Boy,

Create a second macro. You can this call this to search for and copy the info for the road you specify. Here is the code. An example follows the code.

Macro Code

Public Sub FindAndCopyRoad(Road As String) 

 'finds  a given road in column "A" of the active sheet
  Dim Rd As Range

    Set Rd = Range("A1:A65535").Find(What:=Road, After:=Cells(1, 1), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
 
    If Not Rd Is Nothing Then
      'finds last row in column C
       With ActiveSheet
         LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
       End With 
       CopyRows ActiveCell, Cells(LastRow, 3).Offset(2, 0)
       Rd.ClearContents
    End If

End Sub

Example

Sub query()

   Dim LastRow As Long

'brings traffic jam data from web to excel
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.nu.nl/pda_sectie.jsp?n=236&c=75", Destination:=Range("A1"))
        .Name = "pda_sectie.jsp?n=236&c=75"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "5"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
  Activesheet.Columns("B:F").ClearContents

  FindAndCopyRoad "File: A10"
  FindAndCopyRoad "File: A35 "

End Sub

Sincerely,
Leith Ross

Leith,


I put the macros all in module 1, but it fails with an error 424 object required and this is highlighted

Set Rd = Range("A1:A65535").Find(What:=ROAD, After:=Cells(1, 1), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

Moving mouse over it, it says RD=nothing and road= "File: A10"

btw why is it Cell(1,1) in the .find parameters?


Any ideas on why it doesn't work?

Cheers

Science Boy