selectie kopiëren naarpositie andere werkblad

[abracadaver909]

Beste helpmij-ers,

Ik ben bezig aan een macro en die moet er voor zorgen dat een vooraf ingestelde rselectie wordt gekopieerd naar een ander worksheet.
De positie van waar het terecht moet komen wordt bepaald door een celwaarde. Als de macro deze celwaarde terugvindt in rij 4 van sheet1 of sheet2, dan wordt de gekopiëerde selectie 5 cellen onder de cel van de gevonden waarde geplakt in de sheet waar dit gevonden is.

Het stukje code wat ik tot nu toe heb ziet er als volgt uit (vergeef me voor de omslachtigheid, ben nog noob!)

Sub copyCyclus()

Dim bezetCyclus As Range

    Sheets("eerste helft").Range("F4:GD4").Select
    Set cell = Selection.Find(What:=Cells(2, 3).Value, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

If cell Is Nothing Then
    'do it something

Else
    bezetCyclus = Sheets("Cyclus")("C3:H30").Select
    bezetCyclus.Copy
    
    Range(cell).Offset(5, 0).Select
    ActiveSheet.Paste
    
        
End If

Ik heb heel wat zitten rommelen en zit nu echt vast.

Heeft iemand voor mij een passende oplossing of aanwijzing?

Bij voorbaat dank,
Chris

 

[Cobbe]

Doe toch maar een voorbeeldbestandje bij.

 

[abracadaver909]

Ja he. Mijn uitleg is niet al te duidelijk. Wellicht met het bestand wordt het iets duidelijker.
Bekijk bijlage snipperboekrood1.xls

In blad Cyclus vindt je een 7-daags rooster die men kan invullen zoals men wilt. Door op de knop Bezetting kopieren naar jaaroverzicht te drukken, zal dit naar het 1e of 2e blad gekopieerd moeten worden. Zie Module1, onderste Sub (copyCyclus).

Ik probeerde het zo te maken dat in blad Cyclys de waarde van cel C2 werd herkend in blad Eerste helft of blad Tweede helft. In dit geval dus 6 juli. Het zou zo moeten werken dat de cellen B3 t/m I30 worden gekopieerd en vervolgens 5 cellen onder de 6 juli te vinden blad Tweede helft te worden geplakt. Ik weet zeker dat het aan de syntax ligt, maar ik krijg het gewoon niet voor elkaar.

Ik heb blad Namen verwijderd wegens de persoonlijke gegevens, maar qua functionaliteit voor het huidige probleem maakt het niets uit. Ik hoop dat mijn uitleg duidelijker is dan hierboven en wellicht er een oplossing voor is :thumb:

Bij voorbaat dank,

Chris

 

[cow18]

altijd eerst checken of je gegevens wel juist zijn,
bv. de 4e rij van je 2e helft zijn de dagen van de maand en geen datums, de 3e rij zijn datums uit 2010, zo kan je nooit iets vinden.

Sub copyCyclus()

  Dim bezetCyclus As Range, sSh As String, i As Integer, i1 As Integer
  For i1 = 1 To 2                                          '1e of 2e helft
    sSh = IIf(i1 = 1, "eerste helft", "tweede helft")
    On Error Resume Next
    MsgBox CLng(Sheets("Cyclus").Range("C2").Value)
    i = WorksheetFunction.Match(CLng(Sheets("Cyclus").Range("C2").Value), Sheets(sSh).Range("F3:GD3"), 0)  'in hoeveelste cel van dat bereik staat je datum
    If i <> 0 Then Exit For
  Next
  If i = 0 Then MsgBox "datum staat niet in 1e of 2e helft", vbInformation: Exit Sub

  With Sheets("Cyclus")("C3:H30")
    Sheets(sSh).Range("F4:GD4").Cells(6, i).Resize(.Rows.Count, .Columns.Count).Value = .Value
  End With

End Sub

 

[abracadaver909]

Dat schijnt te werken, want ik krijg wel 2x een msgbox met een getal erin en niet de msgbox dat de datum niet te vinden is.
Echter neem het geen gegevens over naar de desbetreffende sheet. Ik zie niet waarom de waardes niet veranderen.

Zou je er nogmaals naar willen kijken, want het grootste gedeelte van wat daar staat is voor mij abracadabra.

Bekijk bijlage snipperboekrood1.xls
Ik heb het aangepaste bestand voor het gemak toegevoegd.

Bij voorbaat dank!

PS Ik heb de datums aangepast, klein schaammomentje

 

[abracadaver909]

Oke.

Na een intensieve speurtocht op een scriptje gestuit wat goed schijnt te werken. Dit script vindt de datum zoals ingevoerd in sheet Cyclus cel C2. Het script zoekt hierbij naar deze datum in alle sheets behalve "Cyclus" genaamd. So far, so good!

Maar nu:
Ik probeerde het script zo te maken dat het op de gevonden sheet 4 rijen onder de cel met de gevonden datum selecteert. Hiervoor gebruikte ik de volgende regel"

Sheets(wsName).Range("FirstAddress").Offset(rowoffset:=4).Select

Om een reden die mij niet duidelijk is loopt de functie hier vast. Zou iemand mij op de juiste weg kunnen helpen?

Voor meer duidelijkheid heb ik het bestand toegevoegd en het gehele sub voor die functie:

Bekijk bijlage snipperboekrood1.xls

Sub FindText()
'Run from standard module, like: Module1.
'Find all data on all sheets!
'Do not search the sheet the found data is copied to!
'List a message box with all the found data addresses, as well!
Dim ws As Worksheet, Found As Range
Dim myText As String, FirstAddress As String
Dim AddressStr As String, foundNum As Integer
Dim wsName As String

myText = DateValue(Sheets("Cyclus").Range("C2"))

If myText = "" Then Exit Sub


For Each ws In ThisWorkbook.Worksheets
With ws
'Do not search sheet4!
If ws.Name = "Cyclus" Then GoTo myNext

Set Found = .Range("F4").EntireRow.Find(what:=DateValue(myText), LookIn:=xlFormulas)

If Not Found Is Nothing Then
FirstAddress = Found.Address(rowabsolute:=False, columnabsolute:=False)
wsName = ws.Name
Do
foundNum = foundNum + 1
AddressStr = AddressStr & .Name & " " & Found.Address(rowabsolute:=False, columnabsolute:=False) & vbCrLf


'Set Found = .UsedRange.FindNext(Found)

'Copy found data row to sheet4 Option!
'Found.EntireRow.Copy _
'Destination:=Worksheets("Sheet4").Range("A65536").End(xlUp).Offset(1, 0)
Loop While Not Found Is Nothing And Found.Address(rowabsolute:=False, columnabsolute:=False) <> FirstAddress
End If

myNext:
End With

Next ws

If Len(AddressStr) Then
'MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _
'AddressStr, vbOKOnly, myText & " found in these cells"

Sheets(wsName).Range("FirstAddress").Offset(rowoffset:=4).Select

Else:

MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
End Sub

Bij voorbaat dank,
Chris