Hulp: Range kopieren naar een andere sheet

[Schreu48]

Hallo iedereen!

Ik wil de waarden van 2 stukken kolommen kopieren naar 2 kolommen in mn datasheet (Database Arrival Patterns).

De volgende code heb ik reeds aan een commandbutton 'Export' gehangen:

Dim paxnumbers As Range
    Dim groupsize As Range
    Dim Lr As Long
    Lr = LastRow(Sheets("Database Arrival Patterns")) + 1
    Set groupsize = Sheets("Arrival Patterns and queues").Range("D18:D420")
    With groupsize
        Set paxnumbers = Sheets("Database Arrival Patterns").Range("B" & Lr). _
        Resize(.Rows.Count, .Columns.Count)
    End With
    paxnumbers.Value = groupsize.Value

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row, _
                                                      
    On Error GoTo 0
End Function

Dit werkt perfect iedere keer als ik op export klik zoekt ie de laatste rij op in kolom D en worden wanneer ik een volgende keer op export klik de waardes eronder geplakt.

ECHTER, heb ik een 2e kolom waarvan ik de waardes ook naar die database wil kopieren, de code ziet er nu als volgt uit:

 Dim paxnumbers As Range
    Dim groupsize As Range
    Dim Lr As Long
    Lr = LastRow(Sheets("Database Arrival Patterns")) + 1
    Set groupsize = Sheets("Arrival Patterns and queues").Range("D18:D420")
    With groupsize
        Set paxnumbers = Sheets("Database Arrival Patterns").Range("B" & Lr). _
        Resize(.Rows.Count, .Columns.Count)
    End With
    paxnumbers.Value = groupsize.Value

    Dim arrivaltime1 As Range
    Dim arrivaltime2 As Range
   
    Lr = LastRow(Sheets("Database Arrival Patterns")) + 1
    Set arrivaltime2 = Sheets("Arrival Patterns and queues").Range("E18:E420")
    With arrivaltime2
        Set arrivaltime1 = Sheets("Database Arrival Patterns").Range("C" & Lr). _
        Resize(.Rows.Count, .Columns.Count)
    End With
    arrivaltime1.Value = arrivaltime2.Value

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row, _
                                                      
    On Error GoTo 0
End Function

En hier gaat het dus mis.... de 1e rij getallen (D18420) wordt mooi in kolom B geplaatst. De 2e rij getallen (E18:E420) zou in kolom C ernaast geplaatst moeten worden. Dit gebeurt ook, alleen worden ze gekopieerd VANAF de laatste rij waar de rij getallen in de kolom ernaast (kolom B) geëindigd is.

Hoe kan ik dit oplossen?

Alvast bedankt!

 

[Schreu48]

de gebruikte code komt trouwens van deze site af:

http://www.exceltip.com/st/Copy_a_range_with_one_Area_to_a_Database_sheet_using_VBA_in_Microsoft_Excel/543.html

 

[Schreu48]

Heb de oplossing gevonden! Voor diegenen die ook ooit dit probleem tegen komen:

Sub Copy_1_Value_Property()
    Dim SourceRange As Range, DestRange As Range
    Dim DestSheet As Worksheet, Lr As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'fill in the Source Sheet and range
    Set SourceRange = Sheets("Sheet1").Range("A1:K1")

    'Fill in the destination sheet and call the LastRow
    'function to find the last row
    Set DestSheet = Sheets("Sheet2")
   [COLOR="Red"] Lr = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row[/COLOR]
    'With the information from the LastRow function we can create a
    'destination cell
    Set DestRange = DestSheet.Range("A" & Lr + 1)

    'We make DestRange the same size as SourceRange and use the Value
    'property to give DestRange the same values
    With SourceRange
        Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
    End With
    DestRange.Value = SourceRange.Value

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Deze code werkt zonder functie en zoekt de laatst gevulde CEL in een KOLOM ipv de laatste RIJ in een complete SHEET.

Veel plezier ermee!

Komt trouwens van deze site af:http://www.rondebruin.nl/copy1.htm