houthakkert
Gebruiker
- Lid geworden
- 18 mrt 2011
- Berichten
- 5
In een Module tracht ik date te kopieren uit een ander excel bestand, dit dient alleen te gebeuren als in het desbetreffende file/sheet cel K een waarde van 2 heeft. Werkte redelijk totdat ik de voorwaarde trachte te beschrijven met deze toevoeging:
For Each cell In Sheets(sBlad).Range(sInlezen)
If (cell.Value = "2") Then.
Daarna kreeg ik de compileerfout, welke ondering de module wordt onderstreept
volledige Module
Const sInlezen As String = "B3:M35 " 'uit te lezen cellen
Const sPad As String = "\\Teamserver1\Users\iedereen\Wachtverslagen\pitsysteem\HISTORY\" 'directory waaruit gelezen moet worden"
Const sBlad As String = "storingenbijzh" 'blad waaruit gelezen moet worden
Sub Ophaal()
Dim inlezen As Variant, fl, c As Range, i As Integer, i0 As Integer, Totaal As String, cWk As String
Dim JR As String, WK As String, Totaal1 As String
Dim rPn As String, cFilter As Integer
Application.ScreenUpdating = False
cFilter = InputBox("Wil je filteren op een 1 een 2 of 3", "Data Filter", "2")
JR = Worksheets("OPTIC_ALLR").Cells(65, 4)
WK = Worksheets("OPTIC_ALLR").Cells(62, 11) 'weeknummer
cWk = Worksheets("OPTIC_ALLR").Cells(65, 7)
rPn = Worksheets("OPTIC_ALLR").Cells(65, 10) 'vervangende sheetnaam wanneer cWday = 1
Totaal = sPad & JR & "\" & cWk 'MsgBox Totaal"
Totaal1 = sPad & JR & "\" & cWk & "\" & rPn 'MsgBox Totaal
i0 = Range(sInlezen).Cells.Count 'aantal cellen die je wenst uit te lezen -1
Application.DisplayAlerts = False
With Sheets("storingenbijzh")
For Each fl In CreateObject("scripting.filesystemobject").Getfolder(Totaal).Files
If Right(fl.Name, 50) = rPn & ".xlsm" Then
Workbooks.Open Totaal & "\" & fl.Name
On Error Resume Next
ReDim inlezen(i0)
inlezen(i0) = fl.Name
i = 1
For Each cell In Sheets(sBlad).Range(sInlezen)
If (cell.Value = "2") Then
For Each c In Sheets(sBlad).Range(sInlezen) 'kies hier het juiste werkblad !!!
inlezen(i) = c.Value 'opeenvolgende cellen worden netjes weggeschreven in die array
i = i + 1
Next
ActiveWorkbook.Close
If Err.Number <> 0 Then
Err.Clear
Else
If c(1) = "V" Then
End If
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, i0 + 1) = inlezen
End If
End If
Next
Sheets("storingenbijzh").Select
'ActiveSheet.Range("A3").AutoFilter Field:=11, Criteria1:=cFilter 'filter data
'Range("A3:M35").Select
Selection.Copy
Sheets("storingenbijzh").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("storingenbijzh").Select
Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("storingenbijzh").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.DisplayAlerts = True
End Sub
Wat gaat er hier mis ?
THX alvast
For Each cell In Sheets(sBlad).Range(sInlezen)
If (cell.Value = "2") Then.
Daarna kreeg ik de compileerfout, welke ondering de module wordt onderstreept
volledige Module
Const sInlezen As String = "B3:M35 " 'uit te lezen cellen
Const sPad As String = "\\Teamserver1\Users\iedereen\Wachtverslagen\pitsysteem\HISTORY\" 'directory waaruit gelezen moet worden"
Const sBlad As String = "storingenbijzh" 'blad waaruit gelezen moet worden
Sub Ophaal()
Dim inlezen As Variant, fl, c As Range, i As Integer, i0 As Integer, Totaal As String, cWk As String
Dim JR As String, WK As String, Totaal1 As String
Dim rPn As String, cFilter As Integer
Application.ScreenUpdating = False
cFilter = InputBox("Wil je filteren op een 1 een 2 of 3", "Data Filter", "2")
JR = Worksheets("OPTIC_ALLR").Cells(65, 4)
WK = Worksheets("OPTIC_ALLR").Cells(62, 11) 'weeknummer
cWk = Worksheets("OPTIC_ALLR").Cells(65, 7)
rPn = Worksheets("OPTIC_ALLR").Cells(65, 10) 'vervangende sheetnaam wanneer cWday = 1
Totaal = sPad & JR & "\" & cWk 'MsgBox Totaal"
Totaal1 = sPad & JR & "\" & cWk & "\" & rPn 'MsgBox Totaal
i0 = Range(sInlezen).Cells.Count 'aantal cellen die je wenst uit te lezen -1
Application.DisplayAlerts = False
With Sheets("storingenbijzh")
For Each fl In CreateObject("scripting.filesystemobject").Getfolder(Totaal).Files
If Right(fl.Name, 50) = rPn & ".xlsm" Then
Workbooks.Open Totaal & "\" & fl.Name
On Error Resume Next
ReDim inlezen(i0)
inlezen(i0) = fl.Name
i = 1
For Each cell In Sheets(sBlad).Range(sInlezen)
If (cell.Value = "2") Then
For Each c In Sheets(sBlad).Range(sInlezen) 'kies hier het juiste werkblad !!!
inlezen(i) = c.Value 'opeenvolgende cellen worden netjes weggeschreven in die array
i = i + 1
Next
ActiveWorkbook.Close
If Err.Number <> 0 Then
Err.Clear
Else
If c(1) = "V" Then
End If
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, i0 + 1) = inlezen
End If
End If
Next
Sheets("storingenbijzh").Select
'ActiveSheet.Range("A3").AutoFilter Field:=11, Criteria1:=cFilter 'filter data
'Range("A3:M35").Select
Selection.Copy
Sheets("storingenbijzh").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("storingenbijzh").Select
Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("storingenbijzh").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.DisplayAlerts = True
End Sub
Wat gaat er hier mis ?
THX alvast