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

Code naar celnaam verwijzen

Status
Niet open voor verdere reacties.
Beste,

Als ik deze 2 codes na elkaar laat lopen dan heb ik de gewenste items, maar wil het in 1 code verwerkt zien anders is het maar zo.

Code: 
Sub invoeren_gegevens_WPL()
Dim sn, i As Long, ii As Long, j As Long, x As Long, n As Long, c As Range, c00, c01, c02, twb As Worksheet
Dim arr
Dim Keuze
Keuze = ActiveSheet.Range("A14")

        'Workbooks.Open Filename:="file:\\sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Planning\Systeem\Laatste versie\Danny\Output.xlsx" 'gegevens werk
        Workbooks.Open ThisWorkbook.Path & "\Output Danny.xlsx" 'gegevens Danny E-schijf
        With ActiveWorkbook
        Set twb = ThisWorkbook.ActiveSheet
        arr = Split(RM-1_RE-1, "_")
        With Workbooks("Output Danny.xlsx").Sheets("Rawdata")
        With .Cells(1).CurrentRegion
        For x = 0 To 1
        If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
            .AutoFilter 1, ">=" & CLng(twb.Cells(1, 4)), 1, "<=" & CLng(twb.Cells(1, 4))
            .AutoFilter 15, IIf(x = 0, "GT-SP-WKSE-15", "GT-SP-WKSM-15")
            .AutoFilter 9, arr(0), 2, arr(1)
                        sn = .Cells(1).CurrentRegion
                        ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
                        For ii = 2 To UBound(sn)
                        If Not .Rows(ii).Hidden Then
                            n = n + 1
                        For j = 1 To UBound(sn, 2)
                          arr2(n, 1) = sn(ii, 3)
                          arr2(n, 2) = sn(ii, 4)
                          arr2(n, 3) = sn(ii, 6)
                          arr2(n, 4) = sn(ii, 11)
                          arr2(n, 9) = sn(ii, 9)
                          arr2(n, 10) = sn(ii, 8)
                          arr2(n, 12) = sn(ii, 13)
                          arr2(n, 13) = sn(ii, 14)
                          arr2(n, 14) = sn(ii, 2)
                        Next j
                        End If
                        Next ii
                        If n > 0 Then
                            twb.Range("c1000").End(xlUp).Offset(1, -2).Resize(n, 14) = arr2
                        n = 0
                        Erase arr2
                        End If
        Next x
        End With
        End With
            .Close 0
        End With
End Sub

Code: 
Sub invoeren_gegevens_WPL()
Dim sn, i As Long, ii As Long, j As Long, x As Long, n As Long, c As Range, c00, c01, c02, twb As Worksheet
Dim arr
Dim Keuze
Keuze = ActiveSheet.Range("A14")

        'Workbooks.Open Filename:="file:\\sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Planning\Systeem\Laatste versie\Danny\Output.xlsx" 'gegevens werk
        Workbooks.Open ThisWorkbook.Path & "\Output Danny.xlsx" 'gegevens Danny E-schijf
        With ActiveWorkbook
        Set twb = ThisWorkbook.ActiveSheet
        arr = Split(RM-DG_RE-DG, "_")
        With Workbooks("Output Danny.xlsx").Sheets("Rawdata")
        With .Cells(1).CurrentRegion
        For x = 0 To 1
        If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
            .AutoFilter 1, ">=" & CLng(twb.Cells(1, 4)), 1, "<=" & CLng(twb.Cells(1, 4))
            .AutoFilter 15, IIf(x = 0, "GT-SP-WKSE-15", "GT-SP-WKSM-15")
            .AutoFilter 9, arr(0), 2, arr(1)
                        sn = .Cells(1).CurrentRegion
                        ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
                        For ii = 2 To UBound(sn)
                        If Not .Rows(ii).Hidden Then
                            n = n + 1
                        For j = 1 To UBound(sn, 2)
                          arr2(n, 1) = sn(ii, 3)
                          arr2(n, 2) = sn(ii, 4)
                          arr2(n, 3) = sn(ii, 6)
                          arr2(n, 4) = sn(ii, 11)
                          arr2(n, 9) = sn(ii, 9)
                          arr2(n, 10) = sn(ii, 8)
                          arr2(n, 12) = sn(ii, 13)
                          arr2(n, 13) = sn(ii, 14)
                          arr2(n, 14) = sn(ii, 2)
                        Next j
                        End If
                        Next ii
                        If n > 0 Then
                            twb.Range("c1000").End(xlUp).Offset(1, -2).Resize(n, 14) = arr2
                        n = 0
                        Erase arr2
                        End If
        Next x
        End With
        End With
            .Close 0
        End With
End Sub
 
Niet getest.
Code: 
Sub invoeren_gegevens_WPL()
Dim sn, i As Long, ii As Long, j As Long, x As Long, n As Long, c As Range, c00, c01, c02, twb As Worksheet
Dim arr
Dim Keuze
Keuze = ActiveSheet.Range("A14")


        'Workbooks.Open Filename:="file:\\sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Planning\Systeem\Laatste versie\Danny\Output.xlsx" 'gegevens werk
        Workbooks.Open ThisWorkbook.Path & "\Output Danny.xlsx" 'gegevens Danny E-schijf
        With ActiveWorkbook
Set twb = ThisWorkbook.ActiveSheet
[COLOR=#0000ff]for each arr in array("RM-1_RE-1","RM-DG_RE-DG")[/COLOR]
[COLOR=#0000ff]    arr = Split(arr, "_")[/COLOR]
     With Workbooks("Output Danny.xlsx").Sheets("Rawdata")
       With .Cells(1).CurrentRegion
        For x = 0 To 1
        If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
            .AutoFilter 1, ">=" & CLng(twb.Cells(1, 4)), 1, "<=" & CLng(twb.Cells(1, 4))
            .AutoFilter 15, IIf(x = 0, "GT-SP-WKSE-15", "GT-SP-WKSM-15")
            .AutoFilter 9, arr(0), 2, arr(1)
                        sn = .Cells(1).CurrentRegion
                        ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
                        For ii = 2 To UBound(sn)
                        If Not .Rows(ii).Hidden Then
                            n = n + 1
                        For j = 1 To UBound(sn, 2)
                          arr2(n, 1) = sn(ii, 3)
                          arr2(n, 2) = sn(ii, 4)
                          arr2(n, 3) = sn(ii, 6)
                          arr2(n, 4) = sn(ii, 11)
                          arr2(n, 9) = sn(ii, 9)
                          arr2(n, 10) = sn(ii, 8)
                          arr2(n, 12) = sn(ii, 13)
                          arr2(n, 13) = sn(ii, 14)
                          arr2(n, 14) = sn(ii, 2)
                        Next j
                        End If
                        Next ii
                        If n > 0 Then
                            twb.Range("c1000").End(xlUp).Offset(1, -2).Resize(n, 14) = arr2
                        n = 0
                        Erase arr2
                        End If
        Next x
        End With
        End With
[COLOR=#0000ff]next arr[/COLOR]

            .Close 0
        End With
End Sub
Ps.
Dit is een 4 dimensionaal array.
Code: 
ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2), 1 To UBound(sn, 3), 1 To UBound(sn, 4))
 
Beste HSV,

Dit lukt, maar dit lost mijn probleem niet op !

Het zit zo, de ene week moet ik in den vroegen RM-1_RE-1 + RM-DG_RE-DG en in de namiddag RM-2_RE-2 ophalen
De andere week in den vroegen RM-2_RE-2 + RM-DG_RE-DG en in de namiddag RM-1_RE-1 ophalen

Heb dus wat zitten experimenteren en Keuze en Keuze2 aangemaakt in cel A13 en A14
De code is dan als volgt:

Code: 
For Each arr In Array(Keuze, Keuze2)
arr = Split(arr, "_")

Deze werkt ook prima, maar als ik 1 keuze leeg laat dan werkt het niet.
Krijg dan fout op volgende regel --> Het subcript valt buiten het bereik

Code: 
.AutoFilter 9, arr(0), 2, arr(1)

Of de keuzes moeten zijn RM-1_RE-1_RM-DG_RE-DG, RM-2_RE-2_RM-DG_RE-DG, RM-1_RE-1, RM-2_RE-2
 
Nieuw stof?
Code: 
Sub hsv()
Dim arr
Dim Keuze As Range
Dim keuze2 As Range
Set Keuze = [a13]
Set keuze2 = [a14]
For Each arr In Array(Keuze, keuze2)
  If Not IsEmpty(arr) Then
    arr = Split(arr, "_")
    MsgBox arr(0) & " en " & arr(1)
  End If
Next arr
End Sub
 
Beste HSV,

Nogmaals dank, nu werkt het zoals het hoort :thumb:
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan