Start Free Trial

asked on

copy dynamic range data from sheet 1 to sheet 2

Hi all,

I have a workbook with 2 sheets. Sheet 1 named "details" sheet 2 named "rec". There are named ranges for each data range which I can manage dynamically.

I am only wanting to transfer data from "details" to "rec" that is within the criteria I have selected. For example, the date and the details (id).

Below is the code I have thus far but it does not deliver the results I need:

Sub transfer_icbr(id As String)
Dim shtF As Worksheet, shtT As Worksheet
Dim lNumRows As Long

Dim lastUpdate As String
lastUpdate = "29/01/2014"

'turn off updates to speed up code execution ->
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

startDate = lastUpdate

Set shtT = ThisWorkbook.Sheets("details")
Set shtF = ThisWorkbook.Sheets("rec")

With shtT.Range("details")
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:= _
        ">=" & Format(startDate, "mm/dd/yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(startDate, "mm/dd/yyyy")
    .AutoFilter Field:=5, Criteria1:="=id"
    
    .Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("rec").Range("rec")
    .AutoFilter
    
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Open in new window

I have attached a sample file without the above code in it. I have also highlighted the data columns yellow for the criteria and the other color is the actual data (columns A, B, C, G, H & I) to copy out to the "rec" sheet.

Anyone able to help?

TA
Book1.xlsm

I tested and tweaked your code.
1. You should always run with Option Explicit
2. The lines I added/changed have a 'chg comment

Option Explicit

Sub transfer_icbr(id As String)
Dim shtF As Worksheet, shtT As Worksheet
Dim lNumRows As Long
Dim startDate As String     'chg
Dim lastUpdate As String
lastUpdate = "29/01/2014"

'turn off updates to speed up code execution ->
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

startDate = lastUpdate

Set shtT = ThisWorkbook.Sheets("detail")    'chg
Set shtF = ThisWorkbook.Sheets("rec")

With shtT.Range("detail")       ' chg
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:= _
        ">=" & Format(startDate, "mm/dd/yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(startDate, "mm/dd/yyyy")
    .AutoFilter Field:=5, Criteria1:="=" & id   'chg
    
    .Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("rec").Range("rec")
    .AutoFilter
    
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Open in new window

ASKER

Thanks for this. I tested and is working for the data transfer. However, the solution does not address the append to last records or the running balance formula requirement.

i.e. Append the records at the bottom of any existing records (excluding header) and add the specified formula noting that if the record is the first row of data, it will always be the receipt value. The formula I included should only be used from row 3 onwards. This is articulated in the file I provided.

Could we work on those before closing please?
TA

See if this comes close.

Option Explicit

Sub transfer_icbr(id As String)
    Dim shtF As Worksheet, shtT As Worksheet
    Dim lNumRows As Long
    Dim startDate As String     'chg
    Dim lastUpdate As String
    Dim rngTo As Range      'chg
    Dim rngFrom As Range    'chg
    
    lastUpdate = "29/01/2014"
    
    'turn off updates to speed up code execution ->
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    startDate = lastUpdate
    
    Set shtT = ThisWorkbook.Sheets("detail")    'chg
    Set shtF = ThisWorkbook.Sheets("rec")
    Set rngTo = shtF.Range("A1").End(xlDown).Offset(1)
    
    With shtT.Range("detail")       ' chg
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:= _
            ">=" & Format(startDate, "mm/dd/yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(startDate, "mm/dd/yyyy")
        .AutoFilter Field:=5, Criteria1:="=" & id   'chg
        Set rngFrom = Intersect(.SpecialCells(xlCellTypeVisible), .Range(.Rows(2), .Rows(.Rows.Count))) 'chg
        
        .Range(rngFrom.Columns(1), rngFrom.Columns(3)).Copy rngTo   'chg
        rngFrom.Columns(7).Copy rngTo.Offset(0, 3)                  'chg
        rngFrom.Columns(10).Copy rngTo.Offset(0, 4)                 'chg
        rngFrom.Columns(9).Copy rngTo.Offset(0, 5)                  'chg
        shtF.Range(rngTo.Offset(-1, 6), rngTo.Offset(shtF.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FillDown     'chg
        
        '.Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=rngTo     'chg
        .AutoFilter
        
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With

End Sub

Open in new window

ASKER

Hi.

I am getting an error on line 34. Object variable or with block variable not set.

TA

are you testing with the same workbook you posted in this thread?

ASKER

No. I am not. I had to separate for confidentiality.

TA

ASKER

Here is my code with named range and sheet change ONLY.

Sub transfer_icbr(id As String)
    Dim shtF As Worksheet, shtT As Worksheet
    Dim lNumRows As Long
    Dim startDate As String     'chg
    Dim lastUpdate As String
    Dim rngTo As Range      'chg
    Dim rngFrom As Range    'chg
    
    lastUpdate = "29/01/2014"
    
    'turn off updates to speed up code execution ->
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    startDate = lastUpdate
    
    Set shtT = ThisWorkbook.Sheets("csb")    'chg
    Set shtF = ThisWorkbook.Sheets("icbr_append")
    Set rngTo = shtF.Range("A1").End(xlDown).Offset(1)
    
    With shtT.Range("tbl_cashbook")       ' chg
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:= _
            ">=" & Format(startDate, "mm/dd/yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(startDate, "mm/dd/yyyy")
        .AutoFilter Field:=5, Criteria1:="=" & id   'chg
        Set rngFrom = Intersect(.SpecialCells(xlCellTypeVisible), .Range(.Rows(2), .Rows(.Rows.Count))) 'chg
        
        .Range(rngFrom.Columns(1), rngFrom.Columns(3)).Copy rngTo   'chg
        rngFrom.Columns(7).Copy rngTo.Offset(0, 3)                  'chg
        rngFrom.Columns(10).Copy rngTo.Offset(0, 4)                 'chg
        rngFrom.Columns(9).Copy rngTo.Offset(0, 5)                  'chg
        shtF.Range(rngTo.Offset(-1, 6), rngTo.Offset(shtF.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FillDown     'chg
        
        '.Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=rngTo     'chg
        .AutoFilter
        
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With

End Sub

Open in new window

Did the sample workbook you posted contain representative data to the workbook you are using in production?

Are you getting an error on line 34?

ASKER

The sample is exactly what I use however, there are a few different columns. I have reposed the exact structure for you to see.
TA
Book1.xlsm

ASKER

Line 34 is the error.

what are you supplying as the parameter to this routine?
the code you originally looking at column 5. Is this correct?

ASKER

Thats right. Column 5 which is name. Sorry to confuse.

ASKER

Column 5 is the parameter. Name as text.

Are you supplying an empty string value?

There are no values in that column.

ASKER

Column e of the detail tab. I will pass the id through a user entry field to the function later.

ASKER

At the moment, when I call the routine, I just parse "customer 1" as an example. For testing only.

ASKER

So when I call the function from the rec sheet, it will return all the records based on the date and the name/id.

None of the customer 1 rows are in the date range. They are from 2012.
I check for the no filtered rows criteria and I've added the lastUpdate date as an optional parameter.

Option Explicit

Public Sub transfer_icbr(id As String, Optional lastUpdate As Date = #1/29/2014#)
    Dim shtF As Worksheet, shtT As Worksheet
    Dim lNumRows As Long
    Dim startDate As Date     'chg
'    Dim lastUpdate As String
    Dim rngTo As Range      'chg
    Dim rngFrom As Range    'chg
    
'    lastUpdate = "01/29/2014"
    
    'turn off updates to speed up code execution ->
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    startDate = lastUpdate
    
    Set shtT = ThisWorkbook.Sheets("detail")    'chg
    Set shtF = ThisWorkbook.Sheets("rec")
    Set rngTo = shtF.Range("A1").End(xlDown).Offset(1)
    
    With shtT.Range("detail")       ' chg
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:= _
            ">=" & Format(startDate, "mm/dd/yyyy"), Operator:=xlAnd, Criteria1:="<=" & Format(startDate, "mm/dd/yyyy")
        .AutoFilter Field:=5, Criteria1:=id    'chg
        Set rngFrom = Intersect(.SpecialCells(xlCellTypeVisible), .Range(.Rows(2), .Rows(.Rows.Count))) 'chg
        If rngFrom Is Nothing Then
            MsgBox "No rows meet your criteria"
        Else
            rngFrom.Columns(1).Copy rngTo                  'chg
            .Range(rngFrom.Columns(4), rngFrom.Columns(5)).Copy rngTo.Offset(0, 1)  'chg
            rngFrom.Columns(9).Copy rngTo.Offset(0, 3)                  'chg
            rngFrom.Columns(12).Copy rngTo.Offset(0, 4)                  'chg
            rngFrom.Columns(11).Copy rngTo.Offset(0, 5)                 'chg
            shtF.Range(rngTo.Offset(-1, 6), rngTo.Offset(shtF.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FillDown     'chg
        End If
        '.Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=rngTo     'chg
        .AutoFilter
        
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With

End Sub

Open in new window

ASKER

Hi,

This is working good but I am only getting one row of data Mark.

Is there a need to place a loop in there?
TA

ASKER

Okay champ, I have managed to tweak this a little. The only thing left to do is to work out how to return all rows instead of just one.

Here is my code:

Public Sub transfer_icbr()
    Dim shtF As Worksheet, shtT As Worksheet
    Dim lNumRows As Long
    Dim startDate As String     'chg
    Dim lastUpdate As String
    Dim rngTo As Range      'chg
    Dim rngFrom As Range    'chg
    Dim id As String
    Dim response As Integer, msg As String, title As String, style As String

    lastUpdate = "01/01/2012"
    
    'turn off updates to speed up code execution ->
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
           
    Set shtT = ThisWorkbook.Sheets("csb")    'chg
    Set shtF = ThisWorkbook.Sheets("icbr_append")
    Set rngTo = shtF.Range("A1").End(xlDown).Offset(1)
    id = shtF.Range("icbr_name")
    
    With shtT.Range("tbl_cashbook")       ' chg
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:= _
            ">=" & Format(lastUpdate, "mm/dd/yyyy")
        .AutoFilter Field:=5, Criteria1:="=" & id   'chg
        
        'setting the range from
        Set rngFrom = Intersect(.SpecialCells(xlCellTypeVisible), .Range(.Rows(2), .Rows(.Rows.Count))) 'chg
                
        If rngFrom Is Nothing Then
            MsgBox "No rows meet your criteria"
        Else
            rngFrom.Columns(1).Copy rngTo                  'chg
            .Range(rngFrom.Columns(4), rngFrom.Columns(5)).Copy rngTo.Offset(0, 1)  'chg
            rngFrom.Columns(9).Copy rngTo.Offset(0, 3)                  'chg
            rngFrom.Columns(12).Copy rngTo.Offset(0, 4)                  'chg
            rngFrom.Columns(11).Copy rngTo.Offset(0, 5)                 'chg
            shtF.Range(rngTo.Offset(-1, 6), rngTo.Offset(shtF.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FillDown     'chg
        End If                
        
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With

End Sub

Open in new window

ASKER CERTIFIED SOLUTION

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

ASKER

Hi there,

Thanks so much for the help.
I have migrated your simplified solution into production and it works fine. The only problem is when there are no existing records in the rngTo worksheet, it copies down the header field which is not what I want.

I already have another range named "detail_formula" which contains the following:

=IF(ISNUMBER((G1)=TRUE),G1+F2-E2,F2)

that can be copied or maybe adapted into the code. What are your thoughts on this?
TA

looks like a reasonable formula to me. You could plop that into the FormulaR1C1 property if you are transferring data to row 2 and then do a Filldown.
The FormulaR1C1 value would be:

=IF(ISNUMBER(R[-1]C)=TRUE),R[-1]C+RC[-1]-RC[-2],RC[-1])

Open in new window

Alternatively, the Filldown could be replaced with the FormulaR1C1 value assignment for the newly transferred rows.

ASKER

Cool, so using your simplified code, how would I incorporate it into the routine?

 Intersect(rngFrom, .Range("A:A,D:E,I:I,L:L,K:K")).Copy rngTo             'chg
           shtTo.Range(rngTo.Offset(-1, 6), rngTo.Offset(shtTo.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FillDown

Open in new window

I have not worked with setting R1C1 formula via vba before. Sorry.

SOLUTION

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Ignore formula in http:#a39973240
corrected formula is:

=IF(ISNUMBER(R[-1]C)=TRUE,R[-1]C+RC[-1]-RC[-2],RC[-1])

Open in new window

ASKER

Excellent stuff Mark. I really do appreciate the time you have taken out here to help me. I have learnt a lot from you in this question, and have already identified tonnes of work that I can apply this strategy to. Cheers. TA

ASKER

Well deserved points. Thanks for your patience. TA

No problem. Glad I could help and thanks for the points.

ASKER

Completed code!

Option Explicit

Open in new window

Public Sub transfer_icbr()
    Dim shtFrom As Worksheet, shtTo As Worksheet, lastUpdate As String, rngTo As Range, rngFrom As Range, _
    lastrow As Long, response As Integer, msg As String, title As String, style As String, id As String
    
    lastUpdate = "01/29/2012"
    
    'turn off updates for code execution ->
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    'setting variables
    Set shtFrom = ThisWorkbook.Sheets("csb")
    Set shtTo = ThisWorkbook.Sheets("icbr_append")
    id = shtTo.Range("icbr_append_name")
    
    'checking for no data in destination
    If IsEmpty(shtTo.Range("icbr_append_start")) = True Then
        Set rngTo = shtTo.Range("A2")
    Else
        Set rngTo = shtTo.Range("A1").End(xlDown).Offset(1)
    End If
        
    With shtFrom.Range("tbl_cashbook")
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:= _
            ">" & Format(lastUpdate, "mm/dd/yyyy")
        .AutoFilter Field:=5, Criteria1:=id
        Set rngFrom = Intersect(.SpecialCells(xlCellTypeVisible), .Range(.Rows(2), .Rows(.Rows.Count)))
        If rngFrom Is Nothing Then
            msg = "Cashbook could not locate any records associated with: " & id & "" & vbCrLf & " " & vbCrLf & _
            "Please check that there are records for this estate or alternatively, select another name and try again."
            title = "Records not found"
            style = vbOKOnly + vbInformation
            response = MsgBox(msg, style, title)
        Else
            Intersect(rngFrom, .Range("A:A,D:E,I:I,L:L,K:K")).Copy rngTo
            shtTo.Range(rngTo.Offset(0, 6), _
            rngTo.Offset(shtTo.Range("A1").End(xlDown).Row - rngTo.Row, 6)).FormulaR1C1 = "=IF(ISNUMBER(R[-1]C)=TRUE,R[-1]C+RC[-1]-RC[-2],RC[-1])"
        End If
        .AutoFilter
    End With
    
    'turn updates back on
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

Open in new window