Typen komen niet met elkaar overeen

[CygneVoler]

Begin dit jaar heb ik eens een code ontvangen van HSV - Harry om een stuk tekst te kunnen kopiëren met een gekleurde regel als scheidingslijn.
Nu ben ik daar verder mee aan het puzzelen en loop tegen iets aan en vraag daarvoor jullie hulp.
Ik heb een aantal "witregels" bovenin het formulier toegevoegd. De 3 bij de "array" ReDim heb ik veranderd in 7 (het aantal regels van waaraf gekopieerd moet worden)
Alleen krijg ik dan de melding dat de typen niet met elkaar overeen komen. Wat zie ik over het hoofd of doe ik niet goed?

Ik kijk uit naar jullie hulp/reactie

Cygne

sn = Cells(1).CurrentRegion
ReDim arr(0 To UBound(sn) - 3, 0 To UBound(sn, 2) - 1) 

bsto.Unprotect ("test")

For i = 3 To UBound(sn)
   For Each j In Array(1, 2, 3, 5, 6, 10, 11, 12) 
        arr(n, jj) = sn(i, j)
        jj = jj + 1
   Next j
 n = n + 1
 jj = 0
 Next i
   With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
     .Offset(2).Resize(UBound(arr) + 1, UBound(arr, 2)) = arr
     .Offset(UBound(arr) + 3).Resize(, 8).Interior.ColorIndex = 15
   End With

 

[HSV]

Je currentregion begon vanaf $A$1.
Nu is dat vanaf $A$6.

Ik ben niet alles nagelopen of het nog wel klopt, maar probeer dit eerst eens.

Private Sub LogIn_Click()
    If LogIn.Tag = "test" Then
    'Unload Me
  
    Dim bsto As Worksheet
    Application.ScreenUpdating = False
    
    Set bsto = Sheets("BestelOverzicht")
    
sn = Cells(6, 1).CurrentRegion
ReDim arr(0 To UBound(sn) - 1, 0 To UBound(sn, 2) - 1) '3 = het aantal regels van waaraf gekopieerd wordt

bsto.Unprotect "test"

For i = 2 To UBound(sn)
   For Each j In Array(1, 2, 3, 5, 6, 10, 11, 12) 'De kolomen welke worden gekopieerd
        arr(n, jj) = sn(i, j)
        jj = jj + 1
   Next j
 n = n + 1
 jj = 0
 Next i
   With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
     .Offset(2).Resize(UBound(arr), UBound(arr, 2)) = arr
     .Offset(UBound(arr) + 2).Resize(, 8).Interior.ColorIndex = 15
   End With
   
  bsto.Protect "test"
   MsgBox ("Tekst is gekopieerd naar het BestelOverzicht")

    Else: MsgBox "Jammer joh!"
    Unload Me
    
    End If
    Unload Me
  
End Sub

 

[CygneVoler]

He Harry, bedankt voor je reactie. In het bijgeleverde bestand werkt het wanneer ik het echter in mijn "werkbestand" kopieer wordt de gekleurde scheidingsregel 22 regels eronder geplaatst! Enig idee waar dat aan kan liggen?

 

[HSV]

Delete eens de lege rijen onder de laatste regel met tekst.
Er kan ergens een teken staan die je niet ziet, en dan wordt Ubound(sn) groter dan wat je werkelijk ziet.

 

[CygneVoler]

Heb ik gedaan maar doet het nog steeds. Kan het ook te maken hebben dat de onderliggende regels voorzien zijn van lijnen? Gekaderd!

 

[Ginger]

Nee, lijnen zullen het verschil niet maken. Heb je soms formules in die lege rijen staan die óf een waarde geven óf een "" als er niets te berekenen is?
Daarnaast... Wat staat er nog bóven die cel A6? Als daar óók nog gevulde aaneengesloten regels staan, zal de opdracht CurrentRegion die regels óók meenemen.

 

[VenA]

Op basis van het voorbeeld bestand kan ik ik het probleem ook niet reproduceren. Wel de code een beetje aangepast.

Private Sub LogIn_Click()
If LogIn.Tag = "test" Then
    ar = Cells(6, 1).CurrentRegion
    ReDim ar1(UBound(ar) - 1, UBound(ar, 2) - 4)
    For j = 2 To UBound(ar)
        For Each it In Array(1, 2, 3, 5, 6, 10, 11, 12)
            ar1(j - 2, jj) = ar(j, it)
            jj = jj + 1
        Next it
        jj = 0
    Next j

    With Sheets("Besteloverzicht")
        .Unprotect "test"
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
        .Protect "test"
    End With
    MsgBox ("Tekst is gekopieerd naar het BestelOverzicht")
  Else
    MsgBox "Jammer joh!"
End If
Unload Me
End Sub

Mogelijk dat je het echte bestand gebruik maakt van een tabel. Dan botst

.Cells(Rows.Count, 1).End(xlUp)

tegen de laatste rij van de tabel. Wat niet per definitie de laatst gevulde rij hoeft te zijn.

 

[HSV]

@CygneVoler,
Sla het echte bestand op als .xlsb en plaats het zonder gevoelige info zodat we kunnen zien waar het fout gaat.

@VenA,
De code is aangepast door Ts, vandaar dat het er een beetje slordig uitziet.
Code nog iets aangepast voor de kleur en de grootte van de array + eenvoudiger msg.

Private Sub LogIn_Click()
Application.ScreenUpdating = False
If LogIn.Tag = "test" Then
  sn = sheets("bestelformulier").Cells(6, 1).CurrentRegion 'om iets te testen in het ander blad kan het handig zijn om het werkblad te benoemen.
  ReDim arr(UBound(sn) - 1, 7)   'of ubound(sn,2)-5 
    For i = 2 To UBound(sn)
       For Each j In Array(1, 2, 3, 5, 6, 10, 11, 12) 'De kolomen welke worden gekopieerd
            arr(i - 2, jj) = sn(i, j)
            jj = jj + 1
       Next j
      jj = 0
     Next i
       With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
         .Parent.Unprotect "test"
         .Offset(2).Resize(UBound(arr), 8) = arr
         .Offset(UBound(arr) + 2).Resize(, 8).Interior.ColorIndex = 15
         .Parent.Protect "test"
       End With
    End If
  MsgBox IIf(LogIn.Tag = "test", "Tekst is gekopieerd naar het BestelOverzicht", "Jammer joh!")
 Unload Me
End Sub

 

[CygneVoler]

@Ginger, het is idd dat de laatste kolom is opgemaakt met "voorwaardelijke opmaak."
Ik zal het bestand "uitkleden" en toevoegen. Ik denk dat dat makkelijker praat.

@VenA ik zal ook jouw aanpassing eens gaan testen.

tot zo ver alvast hartelijk dank.

Wordt vervolgt...

 

[Ginger]

@Ginger, het is idd dat de laatste kolom is opgemaakt met "voorwaardelijke opmaak."

Die heb ik nog ff voor je door een testsheet gegooid. Maar VO maakt ook niet uit voor CurrentRegion....
Ben benieuwd naar je bijlage...

 

[CygneVoler]

Kan het zo zijn dat het komt omdat mijn eerste blad, het bestelformulier, er commando's als verticaal zoeken e.d. instaan?
Als ik nl het aantal regels tel waar de grijze balk wordt neergezet in het overzicht, komt dit overeen met het aantal niet ingevulde regels uit het formulier.
Maar hier staan onzichtbaar" de codes in

 

[HSV]

Dat klopt, daardoor wordt de Ubound(sn) groter dan wat je ziet.

Zo is dat wel op te lossen.
Hier ga ik er dus vanuit dat ergens een formule staat die geen resultaat weergeeft.
Bv in kolom A staan 100 formules, maar een aantal geven resultaat.

Private Sub LogIn_Click()
Application.ScreenUpdating = False
If LogIn.Tag = "test" Then
  sn = Sheets(1).Cells(6, 1).CurrentRegion
  ReDim arr(UBound(sn) - 1, 7)
    For i = 2 To UBound(sn)
      If sn(i, 1) <> "" Then
       For Each j In Array(1, 2, 3, 5, 6, 10, 11, 12) 'De kolomen welke worden gekopieerd
            arr(n, jj) = sn(i, j)
            jj = jj + 1
       Next j
       n = n + 1
      jj = 0
      End If
     Next i
       With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
         .Parent.Unprotect "test"
         .Offset(2).Resize(UBound(arr), 8) = arr
         .Offset(n + 2).Resize(, 8).Interior.ColorIndex = 15
         .Parent.Protect "test"
       End With
    End If
  MsgBox IIf(LogIn.Tag = "test", "Tekst is gekopieerd naar het BestelOverzicht", "Jammer joh!")
 Unload Me
End Sub

 

[CygneVoler]

 

[HSV]

Met een plaatje weten we niet wat er zich allemaal afspeelt.
Ik ga er vanuit dat in kolom A geen formules staan.

Private Sub LogIn_Click()
Application.ScreenUpdating = False
If LogIn.Tag = "test" Then
  sn = Sheets("bestelformulier").Cells(6, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 5, 12)
  ReDim arr(UBound(sn) - 1, 7)
    For i = 2 To UBound(sn)
       For Each j In Array(1, 2, 3, 5, 6, 10, 11, 12) 'De kolomen welke worden gekopieerd
            arr(i - 2, jj) = sn(i, j)
            jj = jj + 1
       Next j
      jj = 0
     Next i
       With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
         .Parent.Unprotect "test"
         .Offset(2).Resize(UBound(arr), 8) = arr
         .Offset(UBound(sn) + 1).Resize(, 8).Interior.ColorIndex = 15
         .Parent.Protect "test"
       End With
    End If
  MsgBox IIf(LogIn.Tag = "test", "Tekst is gekopieerd naar het BestelOverzicht", "Jammer joh!")
 Unload Me
End Sub

 

[CygneVoler]

Harry je bent een held het werkt!

Private Sub LogIn_Click()
Application.ScreenUpdating = False
If LogIn.Tag = "test" Then
  
sn = Sheets(1).Cells(6, 1).CurrentRegion 'instelling currentregion kolom A regel 6

ReDim arr(0 To UBound(sn) - 1, 0 To UBound(sn, 2) - 1)
For i = 2 To UBound(sn)
If sn(i, 1) <> "" Then
   For Each j In Array(1, 2, 3, 4, 5, 6, 9, 10, 11, 8) 'De kolomen welke worden gekopieerd
        arr(n, jj) = sn(i, j)
        jj = jj + 1
   Next j
 n = n + 1
 jj = 0
 End If
 
 Next i
   With Sheets("Besteloverzicht").Cells(Rows.Count, 1).End(xlUp)
         .Parent.Unprotect "test"
         .Offset(2).Resize(UBound(arr), 11) = arr
         .Offset(n + 2).Resize(, 12).Interior.ColorIndex = 15
         .Parent.Protect "test"
       End With
   End If
   
   MsgBox IIf(LogIn.Tag = "test", "Tekst is gekopieerd naar het BestelOverzicht", "Jammer joh!")
 Unload Me
End Sub

Het klopt dat er in de eerste kolom geen formule staat. En het plaatje had ik er bij gedaan om aan te geven dat er codes onderstaan! Maar ik begrijp dat dat wel duidelijk was bij de vraag die ik daarover heb geplaatst. De belangrijkste regel die is toegevoegd lijkt me

If sn(i, 1) <> "" Then

Ik heb zoals je kunt zien jouw eerder gebruikte code dus laten staan. Dit vanwege de foutmelding in de code van bericht 12 van vandaag. Deze gaf de melding dat

arr(n, jj) = sn(i, j)

buiten het bereik viel. Ik ga er van uit dat dit toch geen verdere problemen moet opleveren?

 

[HSV]

Heb je de laatste versie al getest uit #14 van 13:22 uur ?
Die is namelijk sneller doordat de code stopt bij het einde van kolom A.
De andere stopt pas bij het einde van je reeks formules.

 

[CygneVoler]

Ga ik doen Harry! Maar ik was zo blij dat ie het deed dat ik nog niet gedaan heb Laat weer van me horen!

 

[CygneVoler]

Hier krijg ik ook de melding van fout 9 - Subscript valt buiten het bereik. Maar die heb ik aangepast!. Werkt dus ook. zo te zien

 

[HSV]

Krijg je die op onderstaande regel?

sn = Sheets("bestelformulier").Cells(6, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 5, 12)

 

[CygneVoler]

Ja Harry, ik heb dat als volgt aangepast:

sn = Sheets("bestelformulier").Cells(6, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 5, 12) 'kolom A 6de regel
  ReDim arr(UBound(sn) - 1, 9) 'het bereik van de arry 10 posities
    For i = 2 To UBound(sn)
       For Each j In Array(1, 2, 3, 4, 5, 6, 9, 10, 11, 8) 'De kolomen welke worden gekopieerd
            arr(i - 2, jj) = sn(i, j)
            jj = jj + 1
       Next j
      jj = 0
     Next i

Ik heb dus de UBound(sn) -1, 7) aangepast naar 1, 9