Helpmij.nl
Helpmij.nl
Helpmij.nl
Steun Helpmij.nl! Klik hier     Computerprobleem? Klik hier!

Quote

Weergeven resultaten 1 tot 19 van 19

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

  1. #1
    Vraag is niet opgelost

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

    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?

  2. #2
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    Waar heb je in de code bepaald wat WorkBk is, want daar gaat het mis:
    Code:
    WorkBk.Worksheets(1).Range("D7")

  3. #3
    Je bedoeld de variabele WorkBook die aangemaakt is....?

  4. #4
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    De variable WorkBk. Je declareert hem wel, maar stelt hem niet in. En dat is exact wat de foutcode weergeeft.
    Laatst aangepast door SjonR : 9 oktober 2019 om 11:23

  5. #5
    Quote Origineel gepost door SjonR Bekijk Bericht
    De variable WorkBk. Je declareert hem wel, maar stelt hem niet in. En dat is exact wat de foutcode weergeeft.
    Aangepast naar:
    Code:
    Set WorkBk = Workbooks.Open(CurrFile)
    Maar nog steeds foutmelding 91....?

  6. #6
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    Loop de code eens door met F8 en kijk op welke regel de foutmelding betrekking heeft.

  7. #7
    Quote Origineel gepost door SjonR Bekijk Bericht
    Loop de code eens door met F8 en kijk op welke regel de foutmelding betrekking heeft.
    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...?

  8. #8
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    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 = oFS.getfile(WorkBk.FullName).datecreated
    Laatst aangepast door SjonR : 9 oktober 2019 om 13:47

  9. #9
    Quote Origineel gepost door SjonR Bekijk Bericht
    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 = oFS.getfile(WorkBk.FullName).datecreated
    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 aangepast door tijmen_4real : 9 oktober 2019 om 14:06

  10. #10
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    Code:
    Set wb = Workbooks.Open(CurrFile)
                    Set WS = wb.Worksheets(1)
                    Set WorkBk = Workbooks.Open(CurrFile)
    Lijkt mij niet zo handig.
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  11. #11
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    Plaats de hele code eens die je nu hebt. Staan er echt geen niet ingestelde variabelen meer in?

    Sourcerange?

    Wb?
    Laatst aangepast door SjonR : 9 oktober 2019 om 14:37

  12. #12
    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 aangepast door tijmen_4real : 9 oktober 2019 om 14:59

  13. #13
    Giga Senior
    Verenigingslid
    SjonR's avatar
    Geregistreerd
    10 november 2016
    Locatie
    Zaandam
    Afstand tot server
    ±116 km
    Kijk eens hier

  14. #14
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    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
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  15. #15
    Quote Origineel gepost door VenA Bekijk Bericht
    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

  16. #16
    Quote Origineel gepost door VenA Bekijk Bericht
    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
    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?

  17. #17
    Giga Honourable Senior Member
    Verenigingslid

    Geregistreerd
    12 juni 2008
    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
    VBA voor smarties
    VBA is een taal die je moet leren met een grammatica- en een woordenboek.

    http://www.helpmij.nl/forum/announcement.php?f=5
    Plaats svp geen bestanden op andere sites; nadat het bestand daar verwijderd is wordt een forumdraad onbegrijpelijk voor anderen.

  18. #18
    Quote Origineel gepost door VenA Bekijk Bericht
    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
    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....

  19. #19
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    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
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl en business

Partners
Sponsoren