object of blok variabele With is niet ingesteld

Status
Niet open voor verdere reacties.
M

markvdb

Gebruiker
Lid geworden
1 jun 2016
Berichten
12
Onderstaande code werkte goed totdat ik targetvalue 15, 16 en 17 toegevoegd heb
Alles gaat goed tot alle gegevens uit file 2.xlsx zijn overgenomen en geeft dan deze foutmelding
"object of blok variabele With is niet ingesteld"
wat heb ik fout gedaan? :confused:

Option Explicit
Sub ReadFilesInSequence()

Dim FileName As String
Dim FileNumber As Long
Dim PathCrnt As String
Dim RowDestCrnt As Long
Dim SheetDest As String
Dim TgtValue As String
Dim TgtValue2 As String
Dim TgtValue3 As String
Dim TgtValue4 As String
Dim TgtValue5 As String
Dim TgtValue6 As String
Dim TgtValue7 As String
Dim TgtValue8 As String
Dim TgtValue9 As String
Dim TgtValue10 As String
Dim TgtValue11 As String
Dim TgtValue12 As String
Dim TgtValue13 As String
Dim TgtValue14 As String
Dim TgtValue15 As String
Dim TgtValue16 As String
Dim TgtValue17 As String
Dim WBookSrc As Workbook

PathCrnt = ActiveWorkbook.Path & "\aanvragen"
'Het masterbestand staat in dezelfde folder, de detailbestanden (1.xls, 2.xls etc) staan in de subfolder 'aanvragen'

SheetDest = "Blad1" 'Naam tabblad eventueel aanpassen
RowDestCrnt = 2

With Worksheets(SheetDest)
' Delete current contents of destination sheet
Rows("2:" & Rows.Count).ClearContents
End With

FileNumber = 1

Do While True

FileName = Dir$(PathCrnt & "" & FileNumber & ".xls*")
If FileName = "" Then
' File does not exist
Exit Do
End If

Set WBookSrc = Workbooks.Open(PathCrnt & "" & FileName)
With WBookSrc.Worksheets("Blad1") 'Naam tabblad eventueel aanpassen
TgtValue = .Cells(1, "D").Value
TgtValue2 = .Cells(3, "G").Value
TgtValue3 = .Cells(5, "G").Value
TgtValue4 = .Cells(7, "G").Value
TgtValue5 = .Cells(9, "G").Value
TgtValue6 = .Cells(3, "N").Value
TgtValue7 = .Cells(5, "N").Value
TgtValue8 = .Cells(7, "N").Value
TgtValue9 = .Cells(11, "G").Value
TgtValue10 = .Cells(9, "N").Value
TgtValue11 = .Cells(11, "N").Value
TgtValue12 = .Cells(19, "D").Value
TgtValue13 = .Cells(19, "E").Value
TgtValue14 = .Cells(19, "N").Value
TgtValue15 = .Cells(15, "G").Value
TgtValue16 = .Cells(13, "G").Value
TgtValue17 = .Cells(13, "N").Value


End With
WBookSrc.Close SaveChanges:=False
With Worksheets(SheetDest)
.Cells(RowDestCrnt, "A").Value = FileName
.Cells(RowDestCrnt, "B").Value = TgtValue
.Cells(RowDestCrnt, "C").Value = TgtValue2
.Cells(RowDestCrnt, "D").Value = TgtValue3
.Cells(RowDestCrnt, "E").Value = TgtValue4
.Cells(RowDestCrnt, "F").Value = TgtValue5
.Cells(RowDestCrnt, "G").Value = TgtValue6
.Cells(RowDestCrnt, "H").Value = TgtValue7
.Cells(RowDestCrnt, "I").Value = TgtValue8
.Cells(RowDestCrnt, "J").Value = TgtValue9
.Cells(RowDestCrnt, "K").Value = TgtValue10
.Cells(RowDestCrnt, "L").Value = TgtValue11
.Cells(RowDestCrnt, "M").Value = TgtValue12
.Cells(RowDestCrnt, "N").Value = TgtValue13
.Cells(RowDestCrnt, "O").Value = TgtValue14
.Cells(RowDestCrnt, "P").Value = TgtValue15
.Cells(RowDestCrnt, "Q").Value = TgtValue16
.Cells(RowDestCrnt, "R").Value = TgtValue17
End With
RowDestCrnt = RowDestCrnt + 1

FileNumber = FileNumber + 1

Loop

End Sub
 
Zet die code eerst in een code tag en plaats je document.
 
mijn excuses

Code: 
Option Explicit
Sub ReadFilesInSequence()

  Dim FileName As String
  Dim FileNumber As Long
  Dim PathCrnt As String
  Dim RowDestCrnt As Long
  Dim SheetDest As String
  Dim TgtValue As String
  Dim TgtValue2 As String
  Dim TgtValue3 As String
  Dim TgtValue4 As String
  Dim TgtValue5 As String
  Dim TgtValue6 As String
  Dim TgtValue7 As String
  Dim TgtValue8 As String
  Dim TgtValue9 As String
  Dim TgtValue10 As String
  Dim TgtValue11 As String
  Dim TgtValue12 As String
  Dim TgtValue13 As String
  Dim TgtValue14 As String
  Dim TgtValue15 As String
  Dim TgtValue16 As String
  Dim TgtValue17 As String
  Dim WBookSrc As Workbook

  PathCrnt = ActiveWorkbook.Path & "\aanvragen"
  'Het masterbestand staat in dezelfde folder, de detailbestanden (1.xls, 2.xls etc) staan in de subfolder 'aanvragen'

  SheetDest = "Blad1" 'Naam tabblad eventueel aanpassen
  RowDestCrnt = 2

  With Worksheets(SheetDest)
    ' Delete current contents of destination sheet
    Rows("2:" & Rows.Count).ClearContents
  End With

  FileNumber = 1

  Do While True

    FileName = Dir$(PathCrnt & "\" & FileNumber & ".xls*")
    If FileName = "" Then
      ' File does not exist
      Exit Do
    End If

    Set WBookSrc = Workbooks.Open(PathCrnt & "\" & FileName)
    With WBookSrc.Worksheets("Blad1") 'Naam tabblad eventueel aanpassen
      TgtValue = .Cells(1, "D").Value
      TgtValue2 = .Cells(3, "G").Value
      TgtValue3 = .Cells(5, "G").Value
      TgtValue4 = .Cells(7, "G").Value
      TgtValue5 = .Cells(9, "G").Value
      TgtValue6 = .Cells(3, "N").Value
      TgtValue7 = .Cells(5, "N").Value
      TgtValue8 = .Cells(7, "N").Value
      TgtValue9 = .Cells(11, "G").Value
      TgtValue10 = .Cells(9, "N").Value
      TgtValue11 = .Cells(11, "N").Value
      TgtValue12 = .Cells(19, "D").Value
      TgtValue13 = .Cells(19, "E").Value
      TgtValue14 = .Cells(19, "N").Value
      TgtValue15 = .Cells(15, "G").Value
      TgtValue16 = .Cells(13, "G").Value
      TgtValue17 = .Cells(13, "N").Value
          
      
    End With
    WBookSrc.Close SaveChanges:=False
    With Worksheets(SheetDest)
      .Cells(RowDestCrnt, "A").Value = FileName
      .Cells(RowDestCrnt, "B").Value = TgtValue
      .Cells(RowDestCrnt, "C").Value = TgtValue2
      .Cells(RowDestCrnt, "D").Value = TgtValue3
      .Cells(RowDestCrnt, "E").Value = TgtValue4
      .Cells(RowDestCrnt, "F").Value = TgtValue5
      .Cells(RowDestCrnt, "G").Value = TgtValue6
      .Cells(RowDestCrnt, "H").Value = TgtValue7
      .Cells(RowDestCrnt, "I").Value = TgtValue8
      .Cells(RowDestCrnt, "J").Value = TgtValue9
      .Cells(RowDestCrnt, "K").Value = TgtValue10
      .Cells(RowDestCrnt, "L").Value = TgtValue11
      .Cells(RowDestCrnt, "M").Value = TgtValue12
      .Cells(RowDestCrnt, "N").Value = TgtValue13
      .Cells(RowDestCrnt, "O").Value = TgtValue14
      .Cells(RowDestCrnt, "P").Value = TgtValue15
      .Cells(RowDestCrnt, "Q").Value = TgtValue16
      .Cells(RowDestCrnt, "R").Value = TgtValue17
    End With
    RowDestCrnt = RowDestCrnt + 1

    FileNumber = FileNumber + 1

  Loop

End Sub
 
Het ware beter geweest als je het eerste bericht had aangepast...
 
Je hebt al die variabelen helemaal niet nodig, als je de juiste objecten gebruikt:
Code: 
    Set wsDest = ActiveWorkbook.Sheets("Blad1")
    Set wsSource = Workbooks.Open(PathCrnt & "" & FileName).Worksheets("Blad1")
    wsDest.Rows("2:" & Rows.Count).ClearContents
    FileNumber = 1
    RowDestCrnt = 2

    Do While True
        FileName = Dir$(PathCrnt & "" & FileNumber & ".xls*")
        If FileName = "" Then
          ' File does not exist
          Exit Do
        End If
        wsDest.Cells(RowDestCrnt, "A").Value = FileName
        wsDest.Cells(RowDestCrnt, "B").Value = wsSource.Cells(1, "G").Value
        wsDest.Cells(RowDestCrnt, "C").Value = wsSource.Cells(3, "G").Value
        wsDest.Cells(RowDestCrnt, "D").Value = wsSource.Cells(5, "G").Value
        'etc.
        WBookSrc.Close SaveChanges:=False
        RowDestCrnt = RowDestCrnt + 1
        FileNumber = FileNumber + 1
    Loop
Als voorbeeld...
 
ik had blijkbaar nog een paar files open staan die "gelezen" moesten worden :o
mijn macro werkt nu

tnx voor de moeite :thumb:
 
Nu nog die 6 meter code uit het eerste bericht verwijderen of netjes opmaken :D.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan