• 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.

If-statement in With (loop)

Status
Niet open voor verdere reacties.
tijmen_4real

tijmen_4real

Gebruiker
Lid geworden
20 apr 2005
Berichten
338
Hoi,

Ik heb een bestand met een sub. Deze sub zoekt in (sub)mappen naar .xlsm-bestanden.
Uit deze bestanden haalt de macro data uit specifieke velden naar het (status)bestand.

Nu heb ik geprobeerd om er een conditie in te bouwen die deze data uitbreidt aan de hand van een veld (R43) in een gevonden bestand:
- Als er 1 staat, wordt er één array gevuld met data en in het statusbestand getoond.
- Als er 2 staat, worden er twee arrays, ....blabla

Code: 
Sub MergeAllWorkbooks()
  Dim j As Long, jj As Long, it, fl, ar, ar1, ar2, ar3, ar4, ar5
  
  'c00 = locatie waar naar bestanden te zoeken
  c00 = "hier staat dan de locatie"
  
  'constante screen updating uitschakelen
  Application.ScreenUpdating = False
  ReDim ar(0) As String
  
  'mappen doorzoeken naar bestanden
  With CreateObject("Scripting.FileSystemObject").getFolder(c00)
  
    'submappen zoeken naar bestanden
    For Each it In .subfolders
    
      'zoeken naar bestanden
      For Each fl In it.Files
      
        'hit als bestand .xlsm extensie heeft, dan...
        If LCase(Right(fl.Path, 5)) = ".xlsm" Then
          ar(UBound(ar)) = fl.Path
          ReDim Preserve ar(UBound(ar) + 1)
        End If
      Next fl
    Next it
    
    If UBound(ar) Then
      ReDim ar1(UBound(ar) - 1, 22)
      For j = 0 To UBound(ar) - 1
        With GetObject(ar(j)).Sheets(1)
        'als er 1 monster gevonden is: samplenr/leverancier/productnaam/productnr/chargenr/categorie/artnr intern/status
        If .[R43].Value = "1" Then
          ar2 = Array(.[D45].Value, .[H45].Value, .[O45].Value, .[AA45].Value, .[H50].Value, .[J105].Value, .[D189].Value, .[J173].Value)
        ElseIf .[R43].Value = "2" Then
        'als er 2 monsters gevonden zijn: samplenr/leverancier/productnaam/productnr/chargenr/categorie/artnr intern/status
          ar2 = Array(.[D45].Value, .[H45].Value, .[O45].Value, .[AA45].Value, .[H50].Value, .[J105].Value, .[D189].Value, .[J173].Value)
          ar3 = Array(.[D46].Value, .[H46].Value, .[O46].Value, .[AA46].Value, .[H51].Value, .[P105].Value, .[D189].Value, .[P173].Value)
        ElseIf .[R43].Value = "3" Then
        'als er 3 monsters gevonden zijn: samplenr/leverancier/productnaam/productnr/chargenr/categorie/artnr intern/status
          ar2 = Array(.[D45].Value, .[H45].Value, .[O45].Value, .[AA45].Value, .[H50].Value, .[J105].Value, .[D189].Value, .[J173].Value)
          ar3 = Array(.[D46].Value, .[H46].Value, .[O46].Value, .[AA46].Value, .[H51].Value, .[P105].Value, .[D189].Value, .[P173].Value)
          ar4 = Array(.[D47].Value, .[H47].Value, .[O47].Value, .[AA47].Value, .[H52].Value, .[V105].Value, .[D189].Value, .[V173].Value)
        ElseIf .[R43].Value = "4" Then
        'als er 4 monsters gevonden zijn: samplenr/leverancier/productnaam/productnr/chargenr/categorie/artnr intern/status
          ar2 = Array(.[D45].Value, .[H45].Value, .[O45].Value, .[AA45].Value, .[H50].Value, .[J105].Value, .[D189].Value, .[J173].Value)
          ar3 = Array(.[D46].Value, .[H46].Value, .[O46].Value, .[AA46].Value, .[H51].Value, .[P105].Value, .[D189].Value, .[P173].Value)
          ar4 = Array(.[D47].Value, .[H47].Value, .[O47].Value, .[AA47].Value, .[H52].Value, .[V105].Value, .[D189].Value, .[V173].Value)
          ar5 = Array(.[D48].Value, .[H48].Value, .[O48].Value, .[AA48].Value, .[H53].Value, .[AB105].Value, .[D189].Value, .[AB173].Value)
        End If
          .Parent.Close 0
        End With
      Next j
      'locatie bepalen waar data te plaatsen
      ActiveWorkbook.Sheets(1).Cells(2, 1).Resize(UBound(ar1) + 1, 23) = ar1
    End If
  End With
End Sub

Werk helaas niet. Het lijkt erop dat ik geen if-else statement kan/mag toevoegen na de With, want hier gaat het fout (na F8 controle).
Wat doe ik verkeerd? En nog belangrijker: hoe kan ik dit wel bereiken?
Groet,

Tijmen
 
Laatst bewerkt:
Code: 
[COLOR="#FF0000"][SIZE=5].[/SIZE][/COLOR]fl.Path
ipv
Code: 
fl.Path
?
 
Maar even de code van @snb uit jouw vorige draadje wat aangepast naar de nieuwe wens.

Code: 
Sub VenA()
  c00 = "E:\Temp\Temp\"
  ar = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & c00 & "*.xlsm /b/s").StdOut.ReadAll, vbCrLf)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 0 To UBound(ar) - 1
    With GetObject(ar(j))
      ar2 = .Sheets(1).Range("A1:AB189").Value
      .Close 0
    End With
    For y = 1 To ar2(43, 18)
      d(d.Count + 1) = Array(ar2(y + 44, 4), ar2(y + 44, 8), ar2(y + 44, 15), ar2(y + 44, 27), ar2(y + 49, 8), ar2(105, 4 + y * 6), ar2(189, 4), ar2(173, 4 + y * 6))
    Next y
  Next j
  Sheet2.Cells(1).Resize(d.Count, 8) = Application.Index(d.items, 0, 0)
End Sub
 
VenA zei:
Maar even de code van @snb uit jouw vorige draadje wat aangepast naar de nieuwe wens.

Code: 
Sub VenA()
  c00 = "E:\Temp\Temp\"
  ar = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & c00 & "*.xlsm /b/s").StdOut.ReadAll, vbCrLf)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 0 To UBound(ar) - 1
    With GetObject(ar(j))
      ar2 = .Sheets(1).Range("A1:AB189").Value
      .Close 0
    End With
    For y = 1 To ar2(43, 18)
      d(d.Count + 1) = Array(ar2(y + 44, 4), ar2(y + 44, 8), ar2(y + 44, 15), ar2(y + 44, 27), ar2(y + 49, 8), ar2(105, 4 + y * 6), ar2(189, 4), ar2(173, 4 + y * 6))
    Next y
  Next j
  Sheet2.Cells(1).Resize(d.Count, 8) = Application.Index(d.items, 0, 0)
End Sub
Klik om te vergroten...

Bedankt voor je tijd en moeite!
Ik krijg hiermee een foutmelding: 13 (typen komen niet met elkaar overeen)...?
 
Verwijder eerst eens alle alle onnodige quotes.
Op welke regel krijg je de foutmelding? Heb je het pad wel aangepast?

Dit heb je blijkbaar gemist
Plaats eens een voorbeeldbestand met wat wat waar staat en wat het resultaat moet worden.
Klik om te vergroten...

Als de code in het andere draadje prima werkt waarom meld je het daar dan niet en waarom zet je de vraag dan niet op opgelost?
 
Code: 
Sub MergeAllWorkbooks()
Dim j As Long, jj As Long, it, fl, ar, ar1, ar2

  c00 = "Ja, de locatie had ik hier aangepast"
  ar = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & c00 & "*.xlsm /b/s").StdOut.ReadAll, vbCrLf)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 0 To UBound(ar) - 1
    With GetObject(ar(j))
      ar2 = .Sheets(1).Range("A1:AB189").Value
      .Close 0
    End With
    For y = 1 To ar2(43, 18)
      d(d.Count + 1) = Array(ar2(y + 44, 4), ar2(y + 44, 8), ar2(y + 44, 15), ar2(y + 44, 27), ar2(y + 49, 8), ar2(105, 4 + y * 6), ar2(189, 4), ar2(173, 4 + y * 6))
    Next y
  Next j
  Sheet2.Cells(1).Resize(d.Count, 8) = Application.Index(d.items, 0, 0)
End Sub

Voorbeeld in bijlage.
Vorige topic als opgelost gemarkeerd.

Hoor graag van jullie!
Bedankt en groet,

Tijmen
 

Bijlagen

Laatst bewerkt:
't is allemaal wat. Het verwijderen van de onnodige quotes is nog niet echt gelukt.
Ik zou me ook eerst bezig houden met de beveiliging van een project dan kunnen de helpers er ook wat mee. Het enige wat zichtbaar is, is Blad1 maar hier staat behalve een header niets in.

Code: 
With GetObject(ar(j)).Sheets(1)
Zie ik nergens in mijn code.

Lees deze link eerst maar eens door als je verder geholpen wilt worden: https://www.helpmij.nl/forum/announcement.php?f=5
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan