Bestaande code aanpassen

Status
Niet open voor verdere reacties.
D

DeArie

Gebruiker
Lid geworden
15 jul 2016
Berichten
126
Graag zou ik onderstaande code aanpassen:

Code: 
Sub FacturenAanpassen()
      Application.ScreenUpdating = False
      For Each sh In Sheets
        With sh.Cells(10, 1).CurrentRegion
          ar = .Resize(.Rows.Count + 2).Value
          For j = 1 To UBound(ar) - 2
            ar(j, 4) = ar(j, 4) / ar(j, 3)
            ar(j, 5) = ar(j, 4) * ar(j, 3)
            ar(j, 6) =  ar(j, 5) * 1.21
            t1 = t1 + ar(j, 3)
            t2 = t2 + ar(j, 5)
            t3 = t3 + ar(j, 6)
          Next j
          ar(j + 1, 3) = t1
          ar(j + 1, 5) = t2
          ar(j + 1, 6) = t3
          .Resize(UBound(ar)) = ar
        End With
        sh.Range("C:F").HorizontalAlignment = xlCenter
        sh.Range("D:D,F:F").Columns.Insert
        sh.Columns(6).Insert
        sh.Cells(j + 10, 3).Resize(, 7).Borders(xlEdgeTop).Weight = xlMedium
        sh.Cells(j + 10, 3).NumberFormat = "General"
        sh.Cells(j + 10, 7).Resize(, 3).NumberFormat = "$ #,##0.00"
        t1 = 0: t2 = 0: t3 = 0
      Next sh
    End Sub

Zodat hij in kolom 5 en 6 de formule neerzet en dat hij op het laatste alles optelt met autosom nu heb ik onderstaande al aangepast en dat plaatst de formule in de gewenste cellen alleen telt hij het niet meer op en komt de formule daar dus te staan ipv het totaal van de kolom.

Ik vermoed dat het te maken heeft dat "ar" er niet voor of bij staat maar krijg niet gevonden hoe ik dat dan wel zou moeten gebruiken.

Code: 
Sub FacturenAanpassen()
      Application.ScreenUpdating = False
      For Each sh In Sheets
        With sh.Cells(10, 1).CurrentRegion
          ar = .Resize(.Rows.Count + 2).Value
          For j = 1 To UBound(ar) - 2
            ar(j, 4) = ar(j, 4) / ar(j, 3)
            ar(j, 5) = "=PRODUCT(RC[-1],RC[-2])"
            ar(j, 6) = "=PRODUCT(RC[-1],1.21)"
            t1 = t1 + ar(j, 3)
            t2 = t2 + ar(j, 5)
            t3 = t3 + ar(j, 6)
          Next j
          ar(j + 1, 3) = t1
          ar(j + 1, 5) = t2
          ar(j + 1, 6) = t3
          .Resize(UBound(ar)) = ar
        End With
        sh.Range("C:F").HorizontalAlignment = xlCenter
        sh.Range("D:D,F:F").Columns.Insert
        sh.Columns(6).Insert
        sh.Cells(j + 10, 3).Resize(, 7).Borders(xlEdgeTop).Weight = xlMedium
        sh.Cells(j + 10, 3).NumberFormat = "General"
        sh.Cells(j + 10, 7).Resize(, 3).NumberFormat = "$ #,##0.00"
        t1 = 0: t2 = 0: t3 = 0
      Next sh
    End Sub

Als ik bovenste code gebruik en er staat ergens een lege rij tussen dan krijg ik een fout melding is dat zo aan te passen dat hij die dan overslaat en alsnog doorgaat?
VB2
 

Bijlagen

  • Test 6-5-2021.xlsx
    16,8 KB · Weergaven: 12
  • VB 2.xlsx
    18,9 KB · Weergaven: 17
Kan je er niet veel beter voor zorgen dat er geen lege regels in je bereik staan? Die zijn toch volslagen nutteloos? Waarom maak je het jezelf zo moeilijk? (antwoord op die laatste vraag: iedereen heeft recht op ontberingen :d)
 
Klopt ook Helaas komt het zo uit mijn frankeerapparaat is overigens niet het grootse probleem hoor is meestal niet veel maar het had mooi geweest als het kon haha
 
Als je eerst sorteert, kun je de lege rijen dan niet 'uitschakelen'? Eventueel neem je dat sorteren dan mee op in je macro.
 
In die Lege rijen staat meestal wel iets alleen een kolom verder een cijfer of een opmerking die wel bij die specifieke datum moet blijven. Maar zoals gezegd is dat niet veel dus blijf ik dat wel handmatig doen dat is niet het grootste probleem :)
 
Code: 
For j = 1 To UBound(ar) - 2
            If ar(j, 1) <> "" Then
              t1 = t1 + ar(j, 3)
              t2 = t2 + ar(j, 4) * ar(j, 3)
              t3 = t3 + ar(j, 5) * 1.21
              ar(j, 4) = ar(j, 4) / ar(j, 3)
              ar(j, 5) = "=PRODUCT(RC[-1],RC[-2])"
              ar(j, 6) = "=PRODUCT(RC[-1],1.21)"
            End If
          Next j
 
Beste VenA

Dank je wel dat is inderdaad wat ik zocht, is het alleen mogelijk om waar alles opgeteld wordt daar ook (auto)som neer te zetten? Zodat hij alles automatisch optelt.

Alvast bedankt
 
Dan wordt het een beetje anders.

Code: 
Sub FacturenAanpassen()
  Application.ScreenUpdating = False
  For Each sh In Sheets
    With sh
      ar = .Cells(10, 1).CurrentRegion
      For j = 1 To UBound(ar) - 2
        If ar(j, 1) <> "" Then
          ar(j, 4) = ar(j, 4) / ar(j, 3)
          ar(j, 5) = "=PRODUCT(RC[-1],RC[-2])"
          ar(j, 6) = "=PRODUCT(RC[-1],1.21)"
        End If
      Next j
        
      .Cells(10, 1).CurrentRegion = ar
      .Range("C:F").HorizontalAlignment = xlCenter
      .Cells(j + 12, 3).NumberFormat = "General"
      .Cells(j + 12, 4).Resize(, 3).NumberFormat = "$ #,##0.00"
      .Cells(j + 12, 3).Resize(, 4) = Array("=sum(C10:C" & j + 10 & ")", "", "=sum(E10:E" & j + 10 & ")", "=sum(F10:F" & j + 10 & ")")
      .Range("D:D,E:E,F:F").Columns.Insert
      .Cells(j + 12, 3).Resize(, 7).Borders(xlEdgeTop).Weight = xlMedium
    End With
  Next sh
End Sub
 
Laatst bewerkt:
Beste VenA,

Dank je wel hiervoor dit is precies wat ik zocht als ook dat hij de niet ingevulde regels overslaat!!

Dank

Heb nog een paar kleine wijzigingen aangebracht doordat hij in eerste instantie de laatste twee regels oversloeg om de formule in te vullen en de dikke streep onderaan was versprongen dus die heb ik ook weer aangepast.

Code: 
Sub FacturenAanpassen()
  Application.ScreenUpdating = False
  For Each sh In Sheets
    With sh
      ar = .Cells(10, 1).CurrentRegion
      For j = 1 To UBound(ar)[COLOR="#FF0000"] - 0[/COLOR]
        If ar(j, 1) <> "" Then
          ar(j, 4) = ar(j, 4) / ar(j, 3)
          ar(j, 5) = "=PRODUCT(RC[-1],RC[-2])"
          ar(j, 6) = "=PRODUCT(RC[-1],1.21)"
        End If
      Next j
        
      .Cells(10, 1).CurrentRegion = ar
      .Range("C:F").HorizontalAlignment = xlCenter
      .Cells(j + [COLOR="#FF0000"]10[/COLOR], 3).Resize(, 4).NumberFormat = "General"
      .Cells(j + [COLOR="#FF0000"]10[/COLOR], 4).Resize(, 3).NumberFormat = "$ #,##0.00"
      .Cells(j + [COLOR="#FF0000"]10[/COLOR], 3).Resize(, 4) = Array("=sum(C10:C" & j + [COLOR="#FF0000"]9[/COLOR] & ")", "", "=sum(E10:E" & j + [COLOR="#FF0000"]9[/COLOR] & ")", "=sum(F10:F" & j + [COLOR="#FF0000"]9[/COLOR] & ")")
      .Range("D:D,E:E,F:F").Columns.Insert
      .Cells(j + [COLOR="#FF0000"]10[/COLOR], 3).Resize(, 7).Borders(xlEdgeTop).Weight = xlMedium
    End With
  Next sh
End Sub
 
UBound(ar) - 0 zal zeer waarschijnlijk het zelfde zijn als UBound(ar). Verder is het inderdaad een beetje aanpassen om op de juiste rij uit te komen. Het gaat om het idee en mooi dat je het zelf aan hebt kunnen passen:thumb:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan