Werkbladen verplaatsen

[DeArie]

Ik had het volgende opgenomen via de VBA recorder, uiteraard werkt dit goed behalve als een van de werkbladen niet aanwezig is in het werkboek. wat wel eens het geval is.

Sub Macro5()
'
' Macro5 Macro
'

'
    Sheets(Array("100325, @Holmatro Industrial Eq", _
        "100324, @Holmatro Rescue Equipm", "100101, @Intrapost", _
        "100151, @Notaris mr J.K.A. Meij", "100236, @Tribion B.V")).Select
    Sheets("100324, @Holmatro Rescue Equipm").Activate
    Sheets(Array("100325, @Holmatro Industrial Eq", _
        "100324, @Holmatro Rescue Equipm", "100101, @Intrapost", _
        "100151, @Notaris mr J.K.A. Meij", "100236, @Tribion B.V")).Move
End Sub

Nu dacht ik dit te kunnen ondervangen met :

On Error Resume Next

Maar dat werkt helaas niet, heb ook het volgende nog geprobeerd maar ook dat krijg ik helaas niet werkende

Sub test()



  '  On Error Resume Next

   

    Sheets("100101, @Intrapost").Activate False

    Sheets("100236, @Tribion B.V").Activate False

    Sheets("100325, @Holmatro Industrial Eq").Activate False

    Sheets("100325, @Holmatro Rescue Equipm").Activate False

    Sheets("100151, @Notaris mr J.K.A. Meij").Activate False

   

    Selected.Sheets.Move

   

End Sub

Kan iemand mij in de juiste richting helpen?

 

[AHulpje]

Wat wil je precies bereiken met het verschuiven van je werkbladen?

 

[DeArie]

De genoemde werkbladen staan tussen 50 tot 100 andere werkbladen welke op dezelfde manier verwerkt worden, alleen deze moeten net op een andere manier verwerkt worden. Nu haal ik ze er handmatig uit maar ik wilde dat graag automatiseren.
Wat ik dus voor ogen heb is de genoemde werkbladen selecteren en allemaal in een nieuw ( geen specifieke benaming nodig) werkboek te zetten. zodat ik ze daar op de juiste manier kan bewerken.

 

[snb]

Hebben de te verplaatsen werkbladen een gemeenschappelijk kenmerk ?

Waarom staan al die gegevens niet in 1 werkblad ?

 

[DeArie]

het zijn specificaties uit een machine waarmee we werken, welke stuks en gewichten en soorten in een Excel bestand zet vandaar dat ze niet in 1 werkblad staan deze specificaties worden weer gebruikt voor de facturatie.

Hebben geen gemeenschappelijk kenmerk nee. Wel altijd dezelfde benamingen

 

[AHulpje]

Zo misschien:

Sub Kopieer()
    a = Array("100101, @Intrapost", "100236, @Tribion B.V", "100325, @Holmatro Industrial Eq", "100325, @Holmatro Rescue Equipm", "100151, @Notaris mr J.K.A. Meij")
    Dim b()
    n = -1
    For i = 0 To UBound(a)
        If sheetExists(a(i)) Then
            n = n + 1
            ReDim Preserve b(n)
            b(n) = a(i)
        End If
    Next
    Sheets(b).Copy
End Sub

Function sheetExists(sSheet) As Boolean
    On Error Resume Next
    sheetExists = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function

 

[DeArie]

Goedemorgen AHulpje,

Ik heb hem nog iets aangepast voor mezelf maar dit werkt perfect! Dankjewel hiervoor!

Sub VerplaatsWerkbladen()
    a = Array("100101, @Intrapost", "100236, @Tribion B.V", "100325, @Holmatro Industrial Eq", "100324, @Holmatro Rescue Equipm", "100151, @Notaris mr J.K.A. Meij")
    Dim b()
    n = -1
    For i = 0 To UBound(a)
        If sheetExists(a(i)) Then
            n = n + 1
            ReDim Preserve b(n)
            b(n) = a(i)
        End If
    Next
    Sheets(b).Move
End Sub

Function sheetExists(sSheet) As Boolean
    On Error Resume Next
    sheetExists = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function

 

[snb]

of zo:

Sub M_snb
  sn=  Array("100101, @Intrapost", "100236, @Tribion B.V", "100325, @Holmatro Industrial Eq", "100324, @Holmatro Rescue Equipm", "100151, @Notaris mr J.K.A. Meij")

  for j=0 to ubound(sn)
    if evaluate("iserr(" & sn(j) & "!A1)") then sn=filter(sn,sn(j),0)
  next

  sheets(sn).move
End Sub

 

[DeArie]

Ik heb jouw versie ook geprobeerd snb, maar daar geeft hij een fout op:

Fout 13 tijdens uitvoering : Typen komen niet met elkaar overeen

en dan maakt hij het volgende geel:

If Evaluate("iserr(" & sn(j) & "!A1)") Then

 

[DeArie]

@snb

Als ik jouw code goed begrijp kijkt hij naar de gegevens in cel A1? kan het dan zijn dat hij de fout geeft doordat het samengevoegde cellen bevat?

 

[snb]

Met samengevoegde cellen kun je de effektiviteit van iedere VBA code onderuithalen.
Het staat al honderden keren in dit forum: gebruik nooit samengevoegde cellen.

 

[DeArie]

Dit komt zo uit de machine waarmee wij werken, ik zal er voor mezelf rekening mee houden.

 

[snb]

Begin dan elke macro met

for each it in sheets
   it.cells.unmerge
next

Maar het is natuurlijk beter de bedieners van de machine om fatsoenlijke output te vragen.

 

[DeArie]

Dankjewel Hiervoor, ik zal het zeker aan hun vragen.

Zou je me misschien nog kunnen/willen vertellen waarom de code die fout melding aangeeft? ( heb uiteraard ook eerst de samengevoegde cellen gescheiden. )

 

[HSV]

Die komma, spatie en apenstaartje gooien roet in het eten in je array @snb.

Veranderen in:

Evaluate("iserr('" & sn(j) & "'!A1)")

 

[HSV]

Indien er al drie van de vijf bladen missen gaat die in de fout; zo niet.

sn = Array("100101, @Intrapost", "100236, @Tribion B.V", "100325, @Holmatro Industrial Eq", "100324, @Holmatro Rescue Equipm", "100151, @Notaris mr J.K.A. Meij")
  For j = UBound(sn) To 0 Step -1
    If Evaluate("iserr('" & sn(j) & "'!A1)") Then sn = Filter(sn, sn(j), 0)
  Next
If UBound(sn) > 0 Then Sheets(sn).Move

 

[DeArie]

beide codes werken inderdaad, dank hiervoor.

 

[DeArie]

Loop helaas toch nog tegen een probleempje aan, soms worden er werkbladen samengevoegd en komt er (2) achter het werkblad naam te staan waardoor bovenstaande codes het betreffende werkblad niet meer verplaatst. Is het mogelijk deze aan te passen zodat hij kijkt naar cel A1 ( deze veranderd niet ) of naar de 1e 6 cijfers van het werkblad naam?

 

[AHulpje]

Sub VerplaatsWerkbladen()
   a = Array("100101, @Intrapost", "100236, @Tribion B.V", "100325, @Holmatro Industrial Eq", "100325, @Holmatro Rescue Equipm", "100151, @Notaris mr J.K.A. Meij")
    Dim b()
    n = -1
    For i = 0 To UBound(a)
        sh = sheetExists(a(i))
        If sh <> "" Then
            n = n + 1
            ReDim Preserve b(n)
            b(n) = sh
        End If
    Next
    Sheets(b).Move
End Sub

Function sheetExists(sSheet) As String
    For Each sh In Sheets
        If Left(sh.Name, 6) = Left(sSheet, 6) Then
            sheetExists = sh.Name
            Exit Function
        End If
    Next
End Function

 

[DeArie]

Dankjewel AHulpje dit werkt perfect