gezocht: Kluts (waarde optellen over meerdere tabbladen)

Mcstupid · 23 okt 2015

goedendag!!

Ik was bezig om een bestaande code van hier op het forum om te zetten naar een werkbare code voor mijn toepassing, maar ik ben de kluts weer kwijt...

Momenteel heb ik dit:

Code:

Option Explicit

 Sub HSV()

Dim sq As Variant, i As Long, c As Variant, firstaddress As Variant, Sh As Long
Application.ScreenUpdating = False
   With Sheets("Grafiek")
    .Range("AP5:AP" & .Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
sq = .Range("AN1:AN" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    For i = 5 To UBound(sq)
     For Sh = 1 To Sheets.Count
     If Not Sheets(Sh).Name <> Left("WEEK", 4) Then
With Sheets(Sh)
     Set c = .Columns(8).Find(sq(i, 1), , xlFormulas)
    If Not c Is Nothing Then
     firstaddress = c.Address
        Do
          Sheets("Grafiek").Cells(i, 42) = Sheets("Grafiek").Cells(i, 42) + c.Offset(, 19).Value
           Set c = .Columns(8).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
     End With
    End If
    Next Sh
   Next i
  End With
Application.ScreenUpdating = True
End Sub

Om maar in vba taal uit te leggen waar mijn gegevens moeten komen te staan

:d:
Sheets("Grafiek")
.Range("AN5:AN100) = de te zoeken waarden
.Range("AP5:AP100) = de totale waarden over alle tabbladen

Sheets(sh)
.Range("G:G") = de waarde waar gezocht moet worden
.RAnge("S:S") = de waarde die opgeteld wordt over alle tabbladen

De te zoeken waarde staat in AN5:AN100. De totalen over de tabbladen komen 2 kolommen verder in AP.
De waarden die gezocht worden staan verspreid over over tabbladen met de weeknummer als naam in Kolom H. Het resultaat staat in kolom S.

Ik had zelf al een beetje zitten stoeien met de waarden uit de orginele code maar zodra ik iets wijzig, stopt de code bij de Ubound.

Kunnen jullie mij helpen??

Bekijk bijlage KlutsKwijt.zip

gr,
roelof

Ginger · 23 okt 2015

Mcstupid zei:
Kunnen jullie mij helpen??

Vast wel... Maar plaats dan ff je workbook als bijlage zodat de helpers dat niet hoeven proberen na te bouwen....

Mcstupid · 23 okt 2015

Och, helemaal vergeten! Start de laptop ff op en dan post ik m ff

HSV · 23 okt 2015

Zo zou die het moeten doen, ware het niet dat je zoekt in een kolom (s) met getallen naar bv. "aaa,bbb,ccc".
Dat gaat dus niet werken.

Code:

Sub HSV()
 Dim sq As Variant, i As Long, j As Long, c As Variant, firstaddress As Variant, Sh As Worksheet
 Application.ScreenUpdating = False
   With Sheets("Grafiek")
    .Range("AP5:AP" & .Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
 sq = .Range("AN1:AN" & .Cells(.Rows.Count, 40).End(xlUp).Row)
    For i = 5 To UBound(sq)
     For j = 1 To Sheets.Count
       Set Sh = Sheets(j)
     If UCase(Left(Sh.Name, 5)) = "WEEK " Then
With Sh
     Set c = .Columns(19).Find(sq(i, 1), , xlFormulas)
    If Not c Is Nothing Then
     firstaddress = c.Address
        Do
          Sheets("Grafiek").Cells(i, 42) = Sheets("Grafiek").Cells(i, 42) + c.Value
           Set c = .Columns(8).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
     End With
    End If
    Next j
   Next i
  End With
End Sub

Mcstupid · 23 okt 2015

The creator himself!
Thx! Ik ga dit morgen proberen.

In kolom s staan alleen getallen.

HSV · 23 okt 2015

Dat is niet nodig, deze werkt niet zoals in mijn vorig schrijven geschreven.
In welk kolom staat de tekst die gezocht moet worden?

Edit: Maakt ook niet uit; Elke code is een op maat gemaakt iets, dus omschrijf liever wat je wilt bereiken.
Dan kan daar een code voor gemaakt worden.

Mcstupid · 24 okt 2015

Ah ok.

Op tabblad grafiek moeten de totalen komen in kolom AP. De te zoeken waarden staan in kolom AN.

De waarden van kolom AN staan verspreid in kolom H over meerdere tabbladen. De resultaat staat dan op een van tabbladen in kolom S.

Ik hoop dat ik het goed zeg zo.

Deze code komt uit een Invoice die je toen voor iemand genaakt had.
Ik dacht dat wel zou werken dmv wat bereiken en cijfertjes te veranderen.

HSV · 24 okt 2015

Ach zo,

Ik had niet bemerkt dat er kolommen waren verborgen.

Code:

Sub hsv()
Dim sq, i As Long, c, firstaddress As String, Sh As Worksheet
 Application.ScreenUpdating = False
   With Sheets("Grafiek")
      .Range("AP5:AP" & .Cells.SpecialCells(11).Row).ClearContents
 sq = .Range("AN1:AN" & .Cells(Rows.Count, 40).End(xlUp).Row)
    For i = 5 To UBound(sq)
     For Each Sh In Sheets
       If UCase(Left(Sh.Name, 5)) = "WEEK " Then
         Set c = Sh.Columns(8).Find(sq(i, 1), , -4123)
         If Not c Is Nothing Then
            firstaddress = c.Address
            
    Do
         .cells(i,42) = .Cells(i, 42) + c.Offset(, 11).Value
       Set c = Sh.Columns(8).FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstaddress
      
         End If
        End If
    Next Sh
   Next i
 End With
End Sub

Mcstupid · 24 okt 2015

voor het voorbeeldje werkt het perfect!!

Alleen "blijft ie hangen" in het bestand waarvoor ie gebruikt wordt maar komt vermoedelijk omdat dat bestand intussen 44 tabbladen moet afzoeken.

Ik had niet bemerkt dat er kolommen waren verborgen.

Maakt dat iets uit voor een formule?

Btw, bedankt voor het vinden van de kluts!! :thumb:

HSV · 24 okt 2015

Nee, dat maakt in dit geval niet uit, maar ik kon de gegevens zoals "aaa" niet vinden in je bestand.
Op welke regel komt de foutmelding, en wat is de sh.name?

Ik kijk later wel even weer, moet nu eerst weg.

Mcstupid · 24 okt 2015

ik krijg geen foutmelding...

In de Editor druk ik maar op ESC om de uitvoering af te breken. De " Set c = Sh.Columns(8).FindNext(c)" ligt geel op. intussen was ie op Week 26.

HSV · 24 okt 2015

Zet deze regel er eens tussen.

Code:

End If
     [COLOR=#FF0000]firstaddress = ""[/COLOR]
    Next Sh

Mcstupid · 24 okt 2015

done...

Blijft nog steeds hangen.

Viel me wel op dat "Find(sq(i, 1)" leeg is. Klopt dat?

HSV · 24 okt 2015

Dan is: 'c is nothing' en loopt de code door naar 'end if'.
Maak nog eens een zip bestand zodat ik kan testen waar het fout gaat.

Mcstupid · 24 okt 2015

och ja..

In de "Voor_Forum.xlsm" gaat het goed, alleen in het bestand waar de code voor bedoelt is loopt ie vast.
Kan ik anders het orgineel in een pb naar je toesturen?

HSV · 24 okt 2015

Daar moet je lid voor zijn.
Probeer het eens te zippen.

Mcstupid · 24 okt 2015

gaat em niet worden vrees ik.
Orgineel bestand is 2,5 Mb. na zippen is ie 2Mb..

sylvester-ponte · 24 okt 2015

misschien voor de zekerheid de rode tekst toevoegen

Code:

Sub HSV()
 Dim sq As Variant, i As Long, j As Long, c As Variant, firstaddress As Variant, Sh As Worksheet
 Application.ScreenUpdating = False
   With Sheets("Grafiek")
    .Range("AP5:AP" & .Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
 sq = .Range("AN1:AN" & .Cells(.Rows.Count, 40).End(xlUp).Row)
    For i = 5 To UBound(sq)
[COLOR="#FF0000"]If sq(i, 1) <> "" Then[/COLOR]
     For j = 1 To Sheets.Count
       Set Sh = Sheets(j)
     If UCase(Left(Sh.Name, 5)) = "WEEK " Then
With Sh
     Set c = .Columns(19).Find(sq(i, 1), , xlFormulas)
    If Not c Is Nothing Then
     firstaddress = c.Address
        Do
          Sheets("Grafiek").Cells(i, 42) = Sheets("Grafiek").Cells(i, 42) + c.Value
           Set c = .Columns(8).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
     End With
    End If
    Next j
[COLOR="#FF0000"]End If[/COLOR]
   Next i
  End With
End Sub

HSV · 24 okt 2015

Misschien, maar had ik al getest Sylvester.
Als sq(i,1) leeg is geeft het gewoon een 0 (nul) als resultaat in kolom 42.
Daar blijft de loop niet op hangen bij mij.

sylvester-ponte · 24 okt 2015

en deze verkleind het zoekgebied. (en werkt dus per blad )

Code:

Sub hsv()
    Dim sq, i As Long, c, firstaddress As String, Sh As Worksheet, zoekGebied As Range
    ' Application.ScreenUpdating = False
    With Sheets("Grafiek")
        .Range("AP5:AP" & .Cells.SpecialCells(11).Row).ClearContents
        sq = .Range("AN1:AN" & .Cells(Rows.Count, 40).End(xlUp).Row)
        For Each Sh In Sheets
            If UCase(Left(Sh.Name, 5)) = "WEEK " Then
                Set zoekGebied = Intersect(Sh.Columns(8), Sh.UsedRange)
                For i = 5 To UBound(sq)
                    If sq(i, 1) <> "" Then
                    Set c = zoekGebied.Find(sq(i, 1), , -4123)
                    If Not c Is Nothing Then
                        firstaddress = c.Address
                        Do
                            .Cells(i, 42) = .Cells(i, 42) + c.Offset(, 11).Value
                            Set c = zoekGebied.FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> firstaddress
                    End If
                    End If
                Next i
            End If
        Next Sh
    End With
End Sub

gezocht: Kluts (waarde optellen over meerdere tabbladen)

Gebruiker

Terugkerende gebruiker

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Verenigingslid

Inventaris

Verenigingslid

Wij waarderen jouw privacy