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"
Hoe los ik dit op?
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?