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

Fout 91 tijdens uitvoering: Objectvariabele of klokvariabele With is niet ingesteld

Status
Niet open voor verdere reacties.
tijmen_4real

tijmen_4real

Gebruiker
Lid geworden
20 apr 2005
Berichten
338
Hoi

Ik heb de volgende code die in mappen en submappen naar .xlsm-bestanden zoekt en hier vervolgens data uit haalt.
Op deze code, die samengesteld is van twee delen, krijg ik een error:
"Fout 91 tijdens uitvoering: Objectvariabele of klokvariabele With is niet ingesteld"

Code: 
Option Explicit

Sub MergeAllWorkbooks()
    Dim fso As Object
    Dim folder As Object
    Dim subfolders As Object
    Dim MyFile As String
    Dim wb As Workbook
    Dim CurrFile As Object
    Dim i As Long
    Dim SummarySheet As Worksheet
    Dim WS As Worksheet
    Dim WorkBk As Workbook
    Dim NRow As Long
    Dim oFS As Object
    Dim DestRange As Range
    Dim SourceRange As Range
    Dim FileName As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder("H:\A. DUSART\4. KWALITEIT\QUALITY ASSURANCE\Z-nummers (aanvraag nieuwe grondstofleverancier ) +monsterlijst\Z-nummers aanvraag nieuwe grondstof-leveranciers\")
    Set subfolders = folder.subfolders
    Set SummarySheet = ThisWorkbook.Worksheets(1)
    NRow = 3
    
    i = 3
    For Each subfolders In subfolders
    Set CurrFile = subfolders.Files
        For Each CurrFile In CurrFile
            If InStr(CurrFile, ".xlsm") > 0 Then
                Set wb = Workbooks.Open(CurrFile)
                Set WS = wb.Worksheets(1)
        
        'Z-nummer
        SummarySheet.Range("A" & NRow).Value = "Z-" & WorkBk.Worksheets(1).Range("D1")

        'naam grondstof
        SummarySheet.Range("B" & NRow).Value = WorkBk.Worksheets(1).Range("D7")
        
        'naam aanvrager
        SummarySheet.Range("C" & NRow).Value = WorkBk.Worksheets(1).Range("E3")
        
        'Datum document aangemaakt
        SummarySheet.Range("D" & NRow).Value = oFS.getfile(WorkBk.FullName).datecreated
        
        'deel A paraaf
        If WorkBk.Worksheets(1).Range("R30").Value = "" Then
            SummarySheet.Range("F" & NRow).Value = "X"
        Else: SummarySheet.Range("F" & NRow).Value = "V"
        End If
        
        'deel A ondertekend
        If WorkBk.Worksheets(1).Range("R31").Value = "" Then
            SummarySheet.Range("G" & NRow).Value = "X"
        Else: SummarySheet.Range("G" & NRow).Value = "V"
        End If
        
        'deel B paraaf
        If WorkBk.Worksheets(1).Range("R39").Value = "" Then
            SummarySheet.Range("H" & NRow).Value = "X"
        Else: SummarySheet.Range("H" & NRow).Value = "V"
        End If
        
        'deel B ondertekend
        If WorkBk.Worksheets(1).Range("R40").Value = "" Then
            SummarySheet.Range("I" & NRow).Value = "X"
        Else: SummarySheet.Range("I" & NRow).Value = "V"
        End If
        
        'deel C paraaf
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("J" & NRow).Value = "X"
        Else: SummarySheet.Range("J" & NRow).Value = "V"
        End If
        
        'deel C ondertekend
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("K" & NRow).Value = "X"
        Else: SummarySheet.Range("K" & NRow).Value = "V"
        End If
        
        'deel D paraaf
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("L" & NRow).Value = "X"
        Else: SummarySheet.Range("L" & NRow).Value = "V"
        End If
        
        'deel D ondertekend
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("M" & NRow).Value = "X"
        Else: SummarySheet.Range("M" & NRow).Value = "V"
        End If
        
        'deel E paraaf
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("N" & NRow).Value = "X"
        Else: SummarySheet.Range("N" & NRow).Value = "V"
        End If
        
        'deel E ondertekend
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("O" & NRow).Value = "X"
        Else: SummarySheet.Range("O" & NRow).Value = "V"
        End If
        
        'deel F paraaf
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("P" & NRow).Value = "X"
        Else: SummarySheet.Range("P" & NRow).Value = "V"
        End If
        
        'deel F ondertekend
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("Q" & NRow).Value = "X"
        Else: SummarySheet.Range("Q" & NRow).Value = "V"
        End If
        
        'deel G paraaf
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("R" & NRow).Value = "X"
        Else: SummarySheet.Range("R" & NRow).Value = "V"
        End If
        
        'deel G ondertekend
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("S" & NRow).Value = "X"
        Else: SummarySheet.Range("S" & NRow).Value = "V"
        End If
        
        'deel H ondertekend
        If WorkBk.Worksheets(1).Range("R173").Value = "" Then
            SummarySheet.Range("T" & NRow).Value = "X"
        Else: SummarySheet.Range("T" & NRow).Value = "V"
        End If
        
        'deel I ondertekend
        If WorkBk.Worksheets(1).Range("R181").Value = "" Then
            SummarySheet.Range("U" & NRow).Value = "X"
        Else: SummarySheet.Range("U" & NRow).Value = "V"
        End If
        
        'deel J ondertekend
        If WorkBk.Worksheets(1).Range("R186").Value = "" Then
            SummarySheet.Range("V" & NRow).Value = "X"
        Else: SummarySheet.Range("V" & NRow).Value = "V"
        End If
        
        'deel K ondertekend
        If WorkBk.Worksheets(1).Range("R193").Value = "" Then
            SummarySheet.Range("W" & NRow).Value = "X"
        Else: SummarySheet.Range("W" & NRow).Value = "V"
        End If
                
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
                      
        DestRange.Value = SourceRange.Value
        
        NRow = NRow + DestRange.Rows.Count

        WorkBk.Close SaveChanges:=False
        
        'SummarySheet.Range("D" & NRow).Hyperlinks.Add Anchor:=Selection, Address:=FolderPath & FileName, TextToDisplay:="Openen"
        
        FileName = Dir()
                i = i + 1
            End If
        Next
    Next
     
    Set fso = Nothing
    Set folder = Nothing
    Set subfolders = Nothing

With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub

Hoe los ik dit op?
 
Waar heb je in de code bepaald wat WorkBk is, want daar gaat het mis:
Code: 
[COLOR="#FF0000"]WorkBk[/COLOR].Worksheets(1).Range("D7")
 
De variable WorkBk. Je declareert hem wel, maar stelt hem niet in. En dat is exact wat de foutcode weergeeft.
 
Laatst bewerkt:
SjonR zei:
De variable WorkBk. Je declareert hem wel, maar stelt hem niet in. En dat is exact wat de foutcode weergeeft.
Klik om te vergroten...

Aangepast naar:
Code: 
Set WorkBk = Workbooks.Open(CurrFile)
Maar nog steeds foutmelding 91....?
 
Loop de code eens door met F8 en kijk op welke regel de foutmelding betrekking heeft.
 
SjonR zei:
Loop de code eens door met F8 en kijk op welke regel de foutmelding betrekking heeft.
Klik om te vergroten...

Code: 
 Set wb = Workbooks.Open(CurrFile)
                Set WS = wb.Worksheets(1)
                Set WorkBk = Workbooks.Open(CurrFile)
        
        'Z-nummer
        SummarySheet.Range("A" & NRow).Value = "Z-" & WorkBk.Worksheets(1).Range("D1")

        'naam grondstof
        SummarySheet.Range("B" & NRow).Value = WorkBk.Worksheets(1).Range("D7")
        
        'naam aanvrager
        SummarySheet.Range("C" & NRow).Value = WorkBk.Worksheets(1).Range("R3")
        
        'Datum document aangemaakt
        'SummarySheet.Range("D" & NRow).Value = oFS.getfile(WorkBk.FullName).datecreated
        
        'deel A paraaf
        If WorkBk.Worksheets(1).Range("R30").Value = "" Then
            SummarySheet.Range("E" & NRow).Value = "X"
        Else: SummarySheet.Range("E" & NRow).Value = "V"
        End If
        
        'deel A ondertekend
        If WorkBk.Worksheets(1).Range("R31").Value = "" Then
            SummarySheet.Range("F" & NRow).Value = "X"
        Else: SummarySheet.Range("F" & NRow).Value = "V"
        End If
        
        'deel B paraaf
        If WorkBk.Worksheets(1).Range("R39").Value = "" Then
            SummarySheet.Range("G" & NRow).Value = "X"
        Else: SummarySheet.Range("G" & NRow).Value = "V"
        End If
        
        'deel B ondertekend
        If WorkBk.Worksheets(1).Range("R40").Value = "" Then
            SummarySheet.Range("H" & NRow).Value = "X"
        Else: SummarySheet.Range("H" & NRow).Value = "V"
        End If
        
        'deel C paraaf
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("I" & NRow).Value = "X"
        Else: SummarySheet.Range("I" & NRow).Value = "V"
        End If
        
        'deel C ondertekend
        If WorkBk.Worksheets(1).Range("R51").Value = "" Then
            SummarySheet.Range("J" & NRow).Value = "X"
        Else: SummarySheet.Range("J" & NRow).Value = "V"
        End If
        
        'deel D paraaf
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("K" & NRow).Value = "X"
        Else: SummarySheet.Range("K" & NRow).Value = "V"
        End If
        
        'deel D ondertekend
        If WorkBk.Worksheets(1).Range("R75").Value = "" Then
            SummarySheet.Range("L" & NRow).Value = "X"
        Else: SummarySheet.Range("L" & NRow).Value = "V"
        End If
        
        'deel E paraaf
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("M" & NRow).Value = "X"
        Else: SummarySheet.Range("M" & NRow).Value = "V"
        End If
        
        'deel E ondertekend
        If WorkBk.Worksheets(1).Range("R115").Value = "" Then
            SummarySheet.Range("N" & NRow).Value = "X"
        Else: SummarySheet.Range("N" & NRow).Value = "V"
        End If
        
        'deel F paraaf
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("O" & NRow).Value = "X"
        Else: SummarySheet.Range("O" & NRow).Value = "V"
        End If
        
        'deel F ondertekend
        If WorkBk.Worksheets(1).Range("R133").Value = "" Then
            SummarySheet.Range("P" & NRow).Value = "X"
        Else: SummarySheet.Range("P" & NRow).Value = "V"
        End If
        
        'deel G paraaf
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("Q" & NRow).Value = "X"
        Else: SummarySheet.Range("Q" & NRow).Value = "V"
        End If
        
        'deel G ondertekend
        If WorkBk.Worksheets(1).Range("R162").Value = "" Then
            SummarySheet.Range("R" & NRow).Value = "X"
        Else: SummarySheet.Range("R" & NRow).Value = "V"
        End If
        
        'deel H ondertekend
        If WorkBk.Worksheets(1).Range("R173").Value = "" Then
            SummarySheet.Range("S" & NRow).Value = "X"
        Else: SummarySheet.Range("S" & NRow).Value = "V"
        End If
        
        'deel I ondertekend
        If WorkBk.Worksheets(1).Range("R181").Value = "" Then
            SummarySheet.Range("T" & NRow).Value = "X"
        Else: SummarySheet.Range("T" & NRow).Value = "V"
        End If
        
        'deel J ondertekend
        If WorkBk.Worksheets(1).Range("R186").Value = "" Then
            SummarySheet.Range("U" & NRow).Value = "X"
        Else: SummarySheet.Range("U" & NRow).Value = "V"
        End If
        
        'deel K ondertekend
        If WorkBk.Worksheets(1).Range("R193").Value = "" Then
            SummarySheet.Range("V" & NRow).Value = "X"
        Else: SummarySheet.Range("V" & NRow).Value = "V"
        End If
                
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
                      
        DestRange.Value = SourceRange.Value
        
        NRow = NRow + DestRange.Rows.Count

        WorkBk.Close SaveChanges:=False
        
        'SummarySheet.Range("D" & NRow).Hyperlinks.Add Anchor:=Selection, Address:=FolderPath & FileName, TextToDisplay:="Openen"
        
        FileName = Dir()
                i = i + 1
            End If
        Next
    Next
     
    Set fso = Nothing
    Set folder = Nothing
    Set subfolders = Nothing

With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub
Lijkt dan hierin te zitten, want na dit stukje gaat de macro lopen en krijg ik de foutmelding...?
 
hij geeft de fout toch op een specifieke regel ( de laatste gele regel voordat de fout in beeld komt)

Als je ziet waar hij fout gaat zie je dat je ook een andere variabele niet hebt ingesteld:

Code: 
'SummarySheet.Range("D" & NRow).Value = [COLOR="#FF0000"]oFS[/COLOR].getfile(WorkBk.FullName).datecreated
 
Laatst bewerkt:
SjonR zei:
hij geeft de fout toch op een specifieke regel ( de laatste gele regel voordat de fout in beeld komt)

Als je ziet waar hij fout gaat zie je dat je ook een andere variabele niet hebt ingesteld:

Code: 
'SummarySheet.Range("D" & NRow).Value = [COLOR="#FF0000"]oFS[/COLOR].getfile(WorkBk.FullName).datecreated
Klik om te vergroten...

Code: 
Set oFS = CreateObject("Scripting.FileSystemObject")
oFS bij deze ook ingesteld.
Bedankt. Sorry voor m'n noobness, ik probeer er het beste van te maken.

Code: 
Set WorkBk = Workbooks.Open(CurrFile)
lijkt de foutmelding te geven. Ik weet echt niet hoe...?? :(
 
Laatst bewerkt:
Code: 
Set wb = Workbooks.Open(CurrFile)
                Set WS = wb.Worksheets(1)
                Set WorkBk = Workbooks.Open(CurrFile)

Lijkt mij niet zo handig.
 
Plaats de hele code eens die je nu hebt. Staan er echt geen niet ingestelde variabelen meer in?

Sourcerange?

Wb?
 
Laatst bewerkt:
Heb van scratch de twee delen netter samengevoegd, werkt nu zonder problemen:

Code: 
Sub MergeAllWorkbooks()
    Dim fso As Object
    Dim folder As Object
    Dim subfolders As Object
    Dim MyFile As String
    Dim wb As Workbook
    Dim CurrFile As Object
    Dim i As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder("locatie")
    Set subfolders = folder.subfolders
    Set SummarySheet = ThisWorkbook.Worksheets(1)
    
    i = 3
    For Each subfolders In subfolders
    Set CurrFile = subfolders.Files
        For Each CurrFile In CurrFile
            If InStr(CurrFile, ".xlsm") > 0 Then
                Set wb = Workbooks.Open(CurrFile)
                Set WS = wb.Worksheets(1)
                SummarySheet.Cells(i, 1) = WS.Range("D1") 'Z-nummer
                SummarySheet.Cells(i, 2) = WS.Range("D7") 'naam grondstof
                SummarySheet.Cells(i, 3) = WS.Range("R3") 'naam aanvrager
                SummarySheet.Cells(i, 4) = fso.getfile(CurrFile).datecreated 'Datum document aangemaakt
                If WS.Range("R30").Value = "" Then 'deel A - paraaf
                    SummarySheet.Cells(i, 5) = "X"
                Else: SummarySheet.Cells(i, 5) = "V"
                End If
                If WS.Range("R31").Value = "" Then 'deel A - ondertekenen
                    SummarySheet.Cells(i, 6) = "X"
                Else: SummarySheet.Cells(i, 6) = "V"
                End If
                If WS.Range("R39").Value = "" Then 'deel B - paraaf
                    SummarySheet.Cells(i, 7) = "X"
                Else: SummarySheet.Cells(i, 7) = "V"
                End If
                If WS.Range("R40").Value = "" Then 'deel B - ondertekenen
                    SummarySheet.Cells(i, 8) = "X"
                Else: SummarySheet.Cells(i, 8) = "V"
                End If
                If WS.Range("R54").Value = "" Then 'deel C - paraaf
                    SummarySheet.Cells(i, 9) = "X"
                Else: SummarySheet.Cells(i, 9) = "V"
                End If
                If WS.Range("R55").Value = "" Then 'deel C - ondertekenen
                    SummarySheet.Cells(i, 10) = "X"
                Else: SummarySheet.Cells(i, 10) = "V"
                End If
                If WS.Range("R79").Value = "" Then 'deel D - paraaf
                    SummarySheet.Cells(i, 11) = "X"
                Else: SummarySheet.Cells(i, 11) = "V"
                End If
                If WS.Range("R80").Value = "" Then 'deel D - ondertekenen
                    SummarySheet.Cells(i, 12) = "X"
                Else: SummarySheet.Cells(i, 12) = "V"
                End If
                If WS.Range("R120").Value = "" Then 'deel E - paraaf
                    SummarySheet.Cells(i, 13) = "X"
                Else: SummarySheet.Cells(i, 13) = "V"
                End If
                If WS.Range("R121").Value = "" Then 'deel E - ondertekenen
                    SummarySheet.Cells(i, 14) = "X"
                Else: SummarySheet.Cells(i, 14) = "V"
                End If
                If WS.Range("R152").Value = "" Then 'deel F - paraaf
                    SummarySheet.Cells(i, 15) = "X"
                Else: SummarySheet.Cells(i, 15) = "V"
                End If
                If WS.Range("R153").Value = "" Then 'deel F - ondertekenen
                    SummarySheet.Cells(i, 16) = "X"
                Else: SummarySheet.Cells(i, 16) = "V"
                End If
                If WS.Range("R168").Value = "" Then 'deel G - paraaf
                    SummarySheet.Cells(i, 17) = "X"
                Else: SummarySheet.Cells(i, 17) = "V"
                End If
                If WS.Range("R169").Value = "" Then 'deel G - ondertekenen
                    SummarySheet.Cells(i, 18) = "X"
                Else: SummarySheet.Cells(i, 18) = "V"
                End If
                If WS.Range("R180").Value = "" Then 'deel H - ondertekenen
                    SummarySheet.Cells(i, 19) = "X"
                Else: SummarySheet.Cells(i, 19) = "V"
                End If
                If WS.Range("R188").Value = "" Then 'deel I - ondertekenen
                    SummarySheet.Cells(i, 20) = "X"
                Else: SummarySheet.Cells(i, 20) = "V"
                End If
                If WS.Range("R193").Value = "" Then 'deel J - ondertekenen
                    SummarySheet.Cells(i, 21) = "X"
                Else: SummarySheet.Cells(i, 21) = "V"
                End If
                If WS.Range("R200").Value = "" Then 'deel K - ondertekenen
                    SummarySheet.Cells(i, 22) = "X"
                Else: SummarySheet.Cells(i, 22) = "V"
                End If
                
                wb.Close SaveChanges:=False
                i = i + 1
            End If
        Next
    Next
     
    Set fso = Nothing
    Set folder = Nothing
    Set subfolders = Nothing

With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub

Bedankt voor de hulp! Wat ik graag nog zou willen is dat in kolom 23 een hyperlink komt naar het document die op dat moment geopend is.
Ik heb zitten klooien met AddHyperlink enz., maar krijg het niet netjes voor elkaar... Typen komen niet overeen...
Zoiets als:
Code: 
SummarySheet.Cells(i, 23) = '(hyperlink naar document),(tekst = document openen)
 
Laatst bewerkt:
Ik zou eerst de basiscode eens wat vereenvoudigen en versnellen. De bestandsnaam komt in kolom W en daar kan je eenvoudig een stukje code voor toevoegen zodat het hyperlinks worden.

Code: 
Sub VenA()
  Dim j As Long, jj As Long, it, fl, ar, ar1, ar2
  c00 = "E:\Temp\" 'startmap
  Application.ScreenUpdating = False
  ReDim ar(0) As String
  With CreateObject("Scripting.FileSystemObject").getFolder(c00)
    For Each it In .subfolders
      For Each fl In it.Files
        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)
          ar2 = Array(.[D1].Value, .[D7].Value, .[R3].Value, CDate(.Parent.BuiltinDocumentProperties("Creation Date")), .[R30].Value, .[R31].Value, .[R39].Value, .[R40].Value, .[R54].Value, .[R55].Value, _
          .[R79].Value, .[R80].Value, .[R120].Value, .[r121].Value, .[r152].Value, .[R153].Value, .[R168].Value, .[R169].Value, .[R180].Value, .[R188].Value, .[R193].Value, .[R200].Value, ar(j))
          .Parent.Close 0
        End With
        For jj = 0 To 22
          If jj < 4 Or jj > 21 Then ar1(j, jj) = ar2(jj) Else ar1(j, jj) = IIf(ar2(jj) = "", "X", "V")
        Next jj
      Next j
      ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(UBound(ar1) + 1, 23) = ar1
    End If
  End With
End Sub
 
VenA zei:
Ik zou eerst de basiscode eens wat vereenvoudigen en versnellen. De bestandsnaam komt in kolom W en daar kan je eenvoudig een stukje code voor toevoegen zodat het hyperlinks worden.

Code: 
Sub VenA()
  Dim j As Long, jj As Long, it, fl, ar, ar1, ar2
  c00 = "E:\Temp\" 'startmap
  Application.ScreenUpdating = False
  ReDim ar(0) As String
  With CreateObject("Scripting.FileSystemObject").getFolder(c00)
    For Each it In .subfolders
      For Each fl In it.Files
        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)
          ar2 = Array(.[D1].Value, .[D7].Value, .[R3].Value, CDate(.Parent.BuiltinDocumentProperties("Creation Date")), .[R30].Value, .[R31].Value, .[R39].Value, .[R40].Value, .[R54].Value, .[R55].Value, _
          .[R79].Value, .[R80].Value, .[R120].Value, .[r121].Value, .[r152].Value, .[R153].Value, .[R168].Value, .[R169].Value, .[R180].Value, .[R188].Value, .[R193].Value, .[R200].Value, ar(j))
          .Parent.Close 0
        End With
        For jj = 0 To 22
          If jj < 4 Or jj > 21 Then ar1(j, jj) = ar2(jj) Else ar1(j, jj) = IIf(ar2(jj) = "", "X", "V")
        Next jj
      Next j
      ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(UBound(ar1) + 1, 23) = ar1
    End If
  End With
End Sub
Klik om te vergroten...

:eek::eek::eek::eek::eek::eek::eek::eek::eek:
 
VenA zei:
Ik zou eerst de basiscode eens wat vereenvoudigen en versnellen. De bestandsnaam komt in kolom W en daar kan je eenvoudig een stukje code voor toevoegen zodat het hyperlinks worden.

Code: 
Sub VenA()
  Dim j As Long, jj As Long, it, fl, ar, ar1, ar2
  c00 = "E:\Temp\" 'startmap
  Application.ScreenUpdating = False
  ReDim ar(0) As String
  With CreateObject("Scripting.FileSystemObject").getFolder(c00)
    For Each it In .subfolders
      For Each fl In it.Files
        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)
          ar2 = Array(.[D1].Value, .[D7].Value, .[R3].Value, CDate(.Parent.BuiltinDocumentProperties("Creation Date")), .[R30].Value, .[R31].Value, .[R39].Value, .[R40].Value, .[R54].Value, .[R55].Value, _
          .[R79].Value, .[R80].Value, .[R120].Value, .[r121].Value, .[r152].Value, .[R153].Value, .[R168].Value, .[R169].Value, .[R180].Value, .[R188].Value, .[R193].Value, .[R200].Value, ar(j))
          .Parent.Close 0
        End With
        For jj = 0 To 22
          If jj < 4 Or jj > 21 Then ar1(j, jj) = ar2(jj) Else ar1(j, jj) = IIf(ar2(jj) = "", "X", "V")
        Next jj
      Next j
      ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(UBound(ar1) + 1, 23) = ar1
    End If
  End With
End Sub
Klik om te vergroten...

Voor mij is deze code eindbaas-niveau. Prachtig stukje werk! Dank hiervoor.
Nu begrijp ik er niet alles van, maar doe m'n best:

De macro laad de gevraagde gegevens in een Array die dan door het gevonden document geloopt worden.
ar(j) geeft in dit geval de bestandslocatie en naam weer. Maar hoe kan ik hier in deze Array een hyperlink aan toevoegen. Hoe refereer ik naar de locatie (cel) waar de hyperlink te staan komt?
 
Of zo:

Code: 
Sub M_snb_001()
  sq = Array(1, 7, 3, 1, 30, 31, 39, 40, 54, 55, 79, 80, 120, 121, 152, 153, 168, 169, 180, 188, 193, 200)

  sn = Split(CreateObject("wscript.shell").Exec("cmd /c dir ""G:\OF\*.xlsm"" /b/s").StdOut.ReadAll, vbCrLf)
  ReDim sp(UBound(sn), 21)

  For j = 0 To UBound(sn) - 1
     With GetObject(sn(j))
         st = .Sheets(1).Range("A1:R200")
         st(1, 18) = .BuiltinDocumentProperties("Creation Date")
         .Close 0
     End With
        
     For jj = 0 To 21
        sp(j, jj) = st(sq(jj), IIf(jj < 3, 4, 18))
        If jj > 4 And jj < 22 Then sp(j, jj) = IIf(sp(j, jj) = "", "X", "V")
     Next
  Next
      
  ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub
 
VenA zei:
Ik zou eerst de basiscode eens wat vereenvoudigen en versnellen. De bestandsnaam komt in kolom W en daar kan je eenvoudig een stukje code voor toevoegen zodat het hyperlinks worden.

Code: 
Sub VenA()
  Dim j As Long, jj As Long, it, fl, ar, ar1, ar2
  c00 = "E:\Temp\" 'startmap
  Application.ScreenUpdating = False
  ReDim ar(0) As String
  With CreateObject("Scripting.FileSystemObject").getFolder(c00)
    For Each it In .subfolders
      For Each fl In it.Files
        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)
          ar2 = Array(.[D1].Value, .[D7].Value, .[R3].Value, CDate(.Parent.BuiltinDocumentProperties("Creation Date")), .[R30].Value, .[R31].Value, .[R39].Value, .[R40].Value, .[R54].Value, .[R55].Value, _
          .[R79].Value, .[R80].Value, .[R120].Value, .[r121].Value, .[r152].Value, .[R153].Value, .[R168].Value, .[R169].Value, .[R180].Value, .[R188].Value, .[R193].Value, .[R200].Value, ar(j))
          .Parent.Close 0
        End With
        For jj = 0 To 22
          If jj < 4 Or jj > 21 Then ar1(j, jj) = ar2(jj) Else ar1(j, jj) = IIf(ar2(jj) = "", "X", "V")
        Next jj
      Next j
      ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(UBound(ar1) + 1, 23) = ar1
    End If
  End With
End Sub
Klik om te vergroten...

Ik loop al uren te klooien om een hyperlink aan de locatie (ar(j)) toe te kennen, maar kom helaas niet verder. Hoe pas ik die toe in deze array?
Hyperlinks.Add Anchor:=Selection, Address:=ar(j) etc.... geeft direct een foutmelding....
 
Waarom quote je elk bericht? Wordt toch onleesbaar zo? ar(j) bevat alleen het pad en de bestandsnaam. Volgens mij kan het ook niet binnen een array maar moet je het via het werkblad afhandelen. Zelf gebruik ik het nooit maar zoiets zou kunnen werken

Code: 
Sub VenA()
  For Each cl In Columns(23).SpecialCells(2)
    ActiveSheet.Hyperlinks.Add Range(cl.Address), cl.Value
  Next cl
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan