• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Tabblad kopiëren

Status
Niet open voor verdere reacties.
W

wieter

Terugkerende gebruiker
Lid geworden
26 jun 2009
Berichten
1.128
Bij de [GoTo Hell] loopt het mis.
Blad1 moet gekopiëerd worden.
1. Als het blad waarnaar moet gekopiërd worden nog niet bestaat, dan blad bijmaken en kopiëren.
Tot zover is de code OK.
2. Als het blad waarnaar moet gekopiërd worden al wel bestaat, dan kopiëren op de eerstvolgende lege regel van dat blad.
Hier loopt het mis. Als ik de groene regel in de code vervang door de rode regel dan foutmelding.
Wat is er fout?
Code: 
Private Sub CommandButton3_Click()
 tabnaam = Sheets(1).Range("E3").Value
 For S = 1 To Sheets.Count
   If Sheets(S).Name = tabnaam Then GoTo Hell
    Next S
Application.ScreenUpdating = False
    Worksheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = tabnaam
        Sheets("Blad1").Range("A2:U9").Copy
With Sheets(tabnaam).Range("A1")
  .PasteSpecial xlPasteValues
  .PasteSpecial xlPasteColumnWidths
  .PasteSpecial xlPasteFormats
  .Range("A1").Select
End With
Application.ScreenUpdating = True
Sheets("Blad1").Select
    Range("H3:O9").ClearContents
    Range("H3").Select
Exit Sub
Hell:
Sheets("Blad1").Range("A2:U9").Copy
[COLOR="#00FF00"]With Sheets(tabnaam).Range("A9")[/COLOR]
[COLOR="#FF0000"]'With Sheets(tabnaam).Range("E" & Rows.Count).End(xlUp).Row + 1[/COLOR]  
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteFormats
    .Range("A1").Select
  
End With
Application.ScreenUpdating = True
Sheets("Blad1").Select
    Range("H3:O9").ClearContents
    Range("H3").Select
End Sub
 

Bijlagen

Borduur hier maar eens op.
Code: 
If IsError(Evaluate("'" & cl & "'!A1")) Then
    Sheets.Add(, Sheets(Sheets.Count)).Name = cl
 
Dit soort gegevens hoor je zonder opmaak en poespas in een tabel te verzamelen! Is mijn mening:d

Even wat in elkaar gedraaid:

Code: 
Sub VenA()
Application.ScreenUpdating = False
With Sheets("Blad1")
    If IsError(Evaluate(.[E3] & "!A1")) Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = .[E3]
        lr = 1
        sh = ActiveSheet.Name
      Else
        sh = .[E3].Value
        lr = Sheets(sh).Cells(Sheets(sh).Rows.Count, 5).End(xlUp).Offset(1).Row
    End If
    .Range("A2:U9").Copy
    With Sheets(sh).Cells(lr, 1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .Parent.Columns.AutoFit
    End With
    Application.CutCopyMode = False
    .[H3:O9].ClearContents
    .[H3].Select
End With
End Sub

E3 moet natuurlijk wel voldoen aan de voorwaarden voor het aanmaken van een nieuwe tab.
 
Hey VenA,
Ik was al even aan het proberen met die "Evaluate" -functie, maar ik kreeg het niet werkend.
Dan postte jij jouw code.
Als ik die gebruik, gebeurt er iets raar.
Als een nieuw blad moet aangemaakt worden, geeft de allerlaatste regel van de code een fout.
Als het blad al bestaat, werkt de code perfect.
Hoe zou dat komen?
 

Bijlagen

Elk tabblad van je werkboek heeft evenveel rijen.
Code: 
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
With Sheets("Blad1")
    If IsError(Evaluate(.[e3] & "!A1")) Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = .[e3]
        lr = 1
      Else
        lr = Sheets(.[e3].Value).Cells(Rows.Count, 5).End(xlUp).Offset(1).Row
    End If
 .Range("A2:U9").Copy
    With Sheets(.[e3].Value).Cells(lr, 1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteColumnWidths
    End With
    .[H3:O9].ClearContents
    Application.Goto .[H3]
End With
End Sub

Toch nog maar iets anders geschreven omdat er weinig te doen was op het forum.
Code: 
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
With Sheets("Blad1")
    If IsError(Evaluate(.[e3] & "!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = .[e3]
 .Range("A2:U9").Copy
    With Sheets(.[e3].Value)
      With .Cells(IIf(.Cells(1, 5) = "", 1, .Cells(Rows.Count, 5).End(xlUp).Offset(1).Row), 1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteColumnWidths
    End With
   End With
    .[H3:O9].ClearContents
    Application.Goto .[H3]
End With
End Sub
 
Laatst bewerkt:
Voor de zoveelste maal helpen jullie mij vooruit.
Bedankt HSV en VenA
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan