Flytte data fra et ark til andre ark

Denne springer ikke 5 over, men tager ikke records med hvor enten B eller F er blanke. Skrivebeskyttelse er  noget du selv  må klare. Standard er alle celler i et ark sat til skrivebeskyttet, det mangler bare at blive slået til under funktioner / Beskyttelse.


Sub transfer()
Dim recv1 As Range, recv2 As Range
On Error GoTo Fejl
For Each c In Worksheets("Ark").Range("A2", Cells(65536, 1).End(xlUp))
    If Not IsEmpty(c.Offset(, 1)) And Not IsEmpty(c.Offset(, 5)) Then
        Set recv1 = Worksheets(CStr(c.Offset(, 1))).Range("A65536").End(xlUp).Offset(1, 0)
        Set recv2 = Worksheets(CStr(c.Offset(, 5))).Range("A65536").End(xlUp).Offset(1, 0)
        Range(c, c.Offset(0, 6)).Copy
        recv1.PasteSpecial
        recv2.PasteSpecial
    End If
Igen:
Next
Exit Sub

Fejl:
MsgBox "et af disse ark eksisterer ikke " & _
    vbCr & CStr(c.Offset(, 1)) & _
    vbCr & CStr(c.Offset(, 5)) _
    & vbCr & "Record bliver ikke overført"
GoTo Igen
End Sub

Det virker ikke når jeg køre makroen så melder den fejl
disse linier bliver gule


MsgBox "et af disse ark eksisterer ikke " & _
    vbCr & CStr(c.Offset(, 1)) & _
    vbCr & CStr(c.Offset(, 5)) _
    & vbCr & "Record bliver ikke overført"

jeg har sat makroen ind i bogføringsark er det ikke rigtigt

prøv lige at erstatte det med
MsgBox "et af arkene eksisterer ikke"

Så  skriver den object required
og timeglaset er aktiv

Har det noget at sige at der er et ark mellem bogføringsark
og de ark der har numre

Hej

Her er et andet forslag - kan aktiveres via knap i det basale ark
-----------------------------------------------------------------

Const bArk = "bogføringsark"                        'Navn på basis-arkfanen
Const pw = ""                                      'evt. password

Dim sidsteR, aktuelleR
Private Sub CommandButton1_Click()
    startKopiering
   
    MsgBox ("Kopieringen er udført - kopiark beskyttet")
End Sub
Sub startKopiering()
    ActiveWorkbook.Worksheets(bArk).Activate
    aktuelleR = 3

Rem beregn sidste række i basisark
    ActiveCell.SpecialCells(xlLastCell).Select
    sidsteR = ActiveCell.Row

    While aktuelleR < sidsteR
   
Rem 2 ark-referencer
        arkOK (2)
        arkOK (6)
       
        aktuelleR = aktuelleR + 51
    Wend
End Sub
Private Sub arkOK(kol)
Dim tilArk
        tilArk = CStr(Cells(aktuelleR, kol))
       
        If findesArk(tilArk) = True Then
            kopiAfArk tilArk, aktuelleR
        Else
            MsgBox ("Arket " + tilArk + " findes ikke!")
        End If
End Sub
Private Sub kopiAfArk(tilArk, raek)
Dim fraStr, fra As Range, til As Range
    fraStr = "A" + CStr(raek) + ":" + "F" + CStr(raek + 43)

    Set fra = Worksheets(bArk).Range(fraStr)
    fra.Copy
   
    Set til = Worksheets(tilArk).Range("A1")
    til.PasteSpecial
   
   
    With Worksheets(tilArk)
        .Protect password:=pw
    End With
End Sub
Private Function findesArk(Arknavn)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = Arknavn Then
            findesArk = True
            Exit Function
        End If
    Next
End Function

-----------------

MVH

computeren gik helt i baglås og jeg måtte hive strømmen for at kunne komme ud af excelarket så
prøv lige igen jeg er først tilbage i aften vi ses

Det var jo ikke så heldigt - koden er udviklet under Office97.
Hvilken version anvender du?

MVH

jeg mener at det er en office pakke nr. 10

jeg kan ikke huske hvad det er for en jeg har der hjemme jeg prøver og kikke

nej det var istedet 9,0 2000

OK - jeg prøver i morgen programmet på Office2000

MVH

er alle arkerne oprettet og hedder de bare numrene  (100, 200, 300 osv.) ?

Ja alle arkene er oprettet i fanerne før man skal have data over i dem.
men det kan være alle tal fra 1000 op til 9999

jeg skriver hjemme fra nu

kan det være fordi jeg i det første ark "ark1" har en makro der selv
opretter ny ark efter de tal jeg indtaster i kolonne A .når jeg så køre den makro
så tager den en kopi af ark3 " kontiark" og ligger ud i alle de nye faner.
så er det jeg skal bruge en makro der er beskrevet i spørgsmålet ovenfor

Jeg har afprøvet det på Office2000 - ingen problemer.

Arkene skal være oprettet forinden (p.t.) - men selvfølgeligt kan det gøres automatisk.

Kode skal lægges ind på arket "BogføringsArk".

MVH

når jeg køre makroen så stopper den i linie 540 og siger at arket
ikke findes jeg har forinden oprettet fane 1000 og fane 1010
3B tastet 1000 og i 3F 1010
Hjælp.

3B tastet 1000 og i 3F 1010 i "Bogføringsark"+ tekst i A3+C3+d3+e3
så hvad er det jeg gør galt

Jeg vil foreslå, at du piller det gamle kode ud - således at der kun er en model ad gangen.
Hvis det er min version - så fylder det kun 59 linier - så linie 540 siger ikke så meget, hvis jeg skal hjælpe


Har forøvrigt selv prøvet at anvende 1000 & 1010 - i 3B og 3F - arkene oprettet på forhånd - ingen problem.

MVH

jeg kan få det til at fungere en så ikke mere er det sådan at jeg kunne sende
det til dig så du kunne se hvordan det helst skulle se ud

Du er velkommen til at sende det - evt. helen filen - direkte til pb@skivehs.dk

MVH

Jeg Håber Du sender den tilbage når du e.v.t får den til at virke

OK - jeg havde opfattet, at du havde fået det til at fungere. Jeg kan på baggrund af den fremsendte fil se, at proceduren skal gentages i alle de følgende 44 linier.
Det var ikke helt tydeligt for mig fra begyndelsen.
Jeg vender tilbage.

MVH

Hej Sorth

Har forlist din e-mail - vil sende hele min testmappe samt programmet (version 2) til dig.  Send venligst en "tom" mail til mig.

MVH

hej supertekst

det ser ud til at det virker
men som du selv siger var det planen at bogføringsark når det blev
opdateret selv skal forsvinde jeg ved ikke om det er en stører ændring
jeg får først rigtig tid til at se på det imorgen . på forhånd tak

hej supertekst jeg har fået det til at virke
Du skal have mange tak for dit svar.
kan du ikke sende et svar så du kan få dine point

Hej Sorth

Her er et "svar til 30 points".

Godt du har fået det hele til at virke.

Med venlig hilsen

supertekst når du har sent et svar
så kan jeg ikke give point `?????????
prøv igen

Hej Sorth

Gem dine 30 points til fremtidig anvendelse -
det var en fornøjelse at kunne hjælpe.

mvh