werkbladen lezen naar een array

Status
Niet open voor verdere reacties.
E

enrico85

Gebruiker
Lid geworden
13 sep 2013
Berichten
56
Hoi allemaal,

Onderstaande code heb ik een keer gekregen op dit forum.

Code: 
Dim sn, c As Range, dGeboorte As Date, dBegin As Date, sNaam As String, l As Long, WB As Workbook, splits, bOpen As Boolean
  splits = Split("I:\StafDGR\FIA\Administratie\FinAdm\Werkinstructies en kostenplaatsen FA\C_rapportage labnota.xlsx ", "\")
  On Error Resume Next
  Set WB = Workbooks(splits(UBound(splits)))
  bOpen = Not (WB Is Nothing)
  If Not bOpen Then
    Set WB = Workbooks.Open(Join(splits, "\"))
    If WB Is Nothing Then
      MsgBox "kan die file niet openen", vbCritical: Exit Sub
    End If
  End If
  On Error GoTo 0
  sn = WB.Worksheets(1).Range("A4").CurrentRegion          'kopie van je data-gegevens staan in dit blad en lees je naar een array
  If Not bOpen Then WB.Close xlNo

  For Each c In ActiveWorkbook.Sheets("orderregel").UsedRange.Columns("A").SpecialCells(xlConstants) 
    If c.Row > 1 Then
      sNaam = c.Value
      dGeboorte = c.Offset(, 1).Value
      dBsn = c.Offset(, 2).Value
      dBegin = c.Offset(, 6).Value                         
      c.Offset(, 3).Value = "NEE"                     
      For l = 1 To UBound(sn)                              'loop alle gegevens in je array af
        If sn(l, 4) = dBsn And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) Then  
        c.Offset(, 3).Value = "JA"              

           Exit For                                         
        End If
       Next
       End If
       Next

End Sub

Met deze code doet die alleen het eerste werkblad kopiëren naar een array. Hoe kan ik deze code aanpassen dat die het 2de werkblad ook naar een array kopieert?
Zodat ik in deze data ook kan zoeken.

Groet
Enrico
 
Een code draaien op een indexnummer van een tabblad lijkt mij nogal listig. Als het tweede tabblad de gegevens bevat kan je een extra lus gebruiken. bv
Code: 
For j = 1 To 2
  sn = WB.Worksheets(j).Range("A4").CurrentRegion
.....
next j
 
Bedankt voor je bericht.

Ik heb het ertussen geplakt, maar zoals je ziet snap ik er weinig van. Ik heb helaas geen kennis van VBA.

Code: 
  sn = WB.Worksheets(1).Range("A4").CurrentRegion          'kopie van je data-gegevens staan in dit blad en lees je naar een array
  
  For j = 1 To 2
  sn = WB.Worksheets(j).Range("A4").CurrentRegion
  Next j
  
  If Not bOpen Then WB.Close xlNo

Misschien is het makkelijker voor mij om 2 codes te maken en los van elkaar te laten draaien. Maar hoe kan ik alleen het 2de tabblad naar een array lezen en hieruit de gegevens zoeken en overnemen of is het ook makkelijk toe te passen met deze lus?
 
Ik heb nu het volgende geprobeerd:

Code: 
Sub SHO_gedeelte2_BSN_bekend()
'
' SHO Macro
'
'
Dim sn, c As Range, dGeboorte As Date, dBegin As Date, sNaam As String, l As Long, WB As Workbook, splits, bOpen As Boolean
  splits = Split("I:\StafDGR\FIA\Administratie\FinAdm\Werkinstructies en kostenplaatsen FA\C_rapportage labnota.xlsx ", "\")
  On Error Resume Next
  Set WB = Workbooks(splits(UBound(splits)))
  bOpen = Not (WB Is Nothing)
  If Not bOpen Then
    Set WB = Workbooks.Open(Join(splits, "\"))
    If WB Is Nothing Then
      MsgBox "kan die file niet openen", vbCritical: Exit Sub
    End If
  End If
  On Error GoTo 0
  sn = WB.Worksheets(1).Range("A4").CurrentRegion          'kopie van je data-gegevens staan in dit blad en lees je naar een array
  
  
  For j = 1 To 2                                            'toegevoegd 27/12
  sn = WB.Worksheets(j).Range("A4").CurrentRegion           'toegevoegd 27/12
  
  
  If Not bOpen Then WB.Close xlNo

  For Each c In ActiveWorkbook.Sheets("orderregel").UsedRange.Columns("A").SpecialCells(xlConstants)  'loop alle namen af in je C-kolom
    If c.Row > 1 Then
      sNaam = c.Value
      dGeboorte = c.Offset(, 1).Value
      dBsn = c.Offset(, 2).Value
      dBegin = c.Offset(, 6).Value                         'begindatum staat 1 kolom naar rechts
      c.Offset(, 3).Value = "NEE"                      'schrijf alvast dez waarde weg naar je kostenplaats, 1 kolom naar links
      For l = 1 To UBound(sn)                              'loop alle gegevens in je array af
        If sn(l, 4) = dBsn And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) Then  'geboortedatum klopt, deel van de naam ook en valt binnen periode
        c.Offset(, 3).Value = "JA"               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven

           Exit For                                         'spring uit de loop
        End If
       Next
       End If
       Next
       
Next j                                                      'toegevoegd 27/12

End Sub

Het lijkt erop dat die de oorspronkelijke code uitvoert en daarna markeert die de regel : sn = WB.Worksheets(j).Range("A4").CurrentRegion en geeft die aan dat er een automatiserings fout is.

Kan de code ook in 2en worden geknipt. Het is namelijk de bedoeling dat die van het 1ste tabblad de kostenplaats overneemt waar de patient verblijft op datum van verrichting en bij het 2de tabblad moet die zoeken of de patient bekend is ja of nee. Het eerste gedeelte werkt prima met de volgende code
Code: 
Dim sn, c As Range, dGeboorte As Date, dBegin As Date, sNaam As String, l As Long, WB As Workbook, splits, bOpen As Boolean
  splits = Split("I:\StafDGR\FIA\Administratie\FinAdm\Werkinstructies en kostenplaatsen FA\C_rapportage labnota.xlsx ", "\")
  On Error Resume Next
  Set WB = Workbooks(splits(UBound(splits)))
  bOpen = Not (WB Is Nothing)
  If Not bOpen Then
    Set WB = Workbooks.Open(Join(splits, "\"))
    If WB Is Nothing Then
      MsgBox "kan die file niet openen", vbCritical: Exit Sub
    End If
  End If
  On Error GoTo 0
  sn = WB.Worksheets(1).Range("A4").CurrentRegion          'kopie van je data-gegevens staan in dit blad en lees je naar een array
  If Not bOpen Then WB.Close xlNo

  For Each c In ActiveWorkbook.Sheets("orderregel").UsedRange.Columns("A").SpecialCells(xlConstants)  'loop alle namen af in je C-kolom
    If c.Row > 1 Then
      sNaam = c.Value
      dGeboorte = c.Offset(, 1).Value
      dBsn = c.Offset(, 2).Value
      dBegin = c.Offset(, 6).Value                         'begindatum staat 1 kolom naar rechts
      For l = 1 To UBound(sn)                              'loop alle gegevens in je array af
        If sn(l, 4) = dBsn And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) Then  'geboortedatum klopt, deel van de naam ook en valt binnen periode
        Select Case sn(l, 8)                                       'onderzoek de mogelijke waarden van sn(l,10)
  Case 403400 To 403470: c.Offset(, 4).Value = 403400      'ligt die hiertussen, dan schrijf je deze waarde weg
  Case 403700 To 403770: c.Offset(, 4).Value = 403700      '2e mogelijkheid, andere waarde wegschrijven
  Case 403800 To 403870: c.Offset(, 4).Value = 403800
  Case 403900 To 403980: c.Offset(, 4).Value = 403900
  Case 405700 To 405770: c.Offset(, 4).Value = 405720
  Case 405800 To 405870: c.Offset(, 4).Value = 405820
  Case 405900 To 405970: c.Offset(, 4).Value = 405920
  Case 407640 To 407680: c.Offset(, 4).Value = 407100
  Case 407700 To 407900: c.Offset(, 4).Value = 407100
  Case 601100 To 602599: c.Offset(, 4).Value = 602600
  Case 603200 To 603980: c.Offset(, 4).Value = 603170
  Case Else: c.Offset(, 4).Value = sn(l, 8)               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven
End Select
           Exit For                                         'spring uit de loop
        End If
       Next
       End If
       Next

End Sub

Is het handig om dit in 2 gedeeltes te doen of kan dit wel werken met een lus?
 
Begin bij het begin en plaats dus de beide excelbestanden. Ik vind het samenraapsel aan code te onleesbaar om er iets werkend van te maken.
 
VenA zei:
Begin bij het begin en plaats dus de beide excelbestanden. Ik vind het samenraapsel aan code te onleesbaar om er iets werkend van te maken.
Klik om te vergroten...

Het is de bedoeling dat die op basis van BSN (factuur, kolom C) en verrichtingsdatum (factuur, kolom G) de juiste gegevens uit de rapportages haalt.

In het excelbestand factuur kolom D moet die zoeken in het excelbestand rapportage tabblad "Ambulant" of een cliënt in behandeling is.
Als die op datum van prestatie in behandeling is moet die waarde "Ja" weergeven, zo niet dan waarde "Nee"

In het excelbestand factuur kolom E moet die zoeken in het excelbestand rapportage tabblad "Klinisch" of een cliënt klinisch is op genomen.
Als die op datum van prestatie klinisch is opgenomen moet die de waarde van kolom H overnemen uit de rapportage, zo niet waarde Niet gevonden weergeven.

Dit laatste werkt prima met de volgende code
Code: 
Dim sn, c As Range, dGeboorte As Date, dBegin As Date, sNaam As String, l As Long, WB As Workbook, splits, bOpen As Boolean
  splits = Split("I:\StafDGR\FIA\Administratie\FinAdm\Werkinstructies en kostenplaatsen FA\C_rapportage labnota.xlsx ", "\")
  On Error Resume Next
  Set WB = Workbooks(splits(UBound(splits)))
  bOpen = Not (WB Is Nothing)
  If Not bOpen Then
    Set WB = Workbooks.Open(Join(splits, "\"))
    If WB Is Nothing Then
      MsgBox "kan die file niet openen", vbCritical: Exit Sub
    End If
  End If
  On Error GoTo 0
  sn = WB.Worksheets(1).Range("A4").CurrentRegion          'kopie van je data-gegevens staan in dit blad en lees je naar een array
  If Not bOpen Then WB.Close xlNo

  For Each c In ActiveWorkbook.Sheets("orderregel").UsedRange.Columns("A").SpecialCells(xlConstants)  'loop alle namen af in je C-kolom
    If c.Row > 1 Then
      sNaam = c.Value
      dGeboorte = c.Offset(, 1).Value
      dBsn = c.Offset(, 2).Value
      dBegin = c.Offset(, 6).Value                         'begindatum staat 1 kolom naar rechts
      c.Offset(, 4).Value = "Niet gevonden"
      For l = 1 To UBound(sn)                              'loop alle gegevens in je array af
        If sn(l, 4) = dBsn And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) Then  'geboortedatum klopt, deel van de naam ook en valt binnen periode
        Select Case sn(l, 8)                                       'onderzoek de mogelijke waarden van sn(l,10)
  Case 403400 To 403470: c.Offset(, 4).Value = 403400      'ligt die hiertussen, dan schrijf je deze waarde weg
  Case 403700 To 403770: c.Offset(, 4).Value = 403700      '2e mogelijkheid, andere waarde wegschrijven
  Case 403800 To 403870: c.Offset(, 4).Value = 403800
  Case 403900 To 403980: c.Offset(, 4).Value = 403900
  Case 405700 To 405770: c.Offset(, 4).Value = 405720
  Case 405800 To 405870: c.Offset(, 4).Value = 405820
  Case 405900 To 405970: c.Offset(, 4).Value = 405920
  Case 407640 To 407680: c.Offset(, 4).Value = 407100
  Case 407700 To 407900: c.Offset(, 4).Value = 407100
  Case 601100 To 602599: c.Offset(, 4).Value = 602600
  Case 603200 To 603980: c.Offset(, 4).Value = 603170
  Case Else: c.Offset(, 4).Value = sn(l, 8)               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven
End Select
           Exit For                                         'spring uit de loop
        End If
       Next
       End If
       Next

End Sub

Het nieuwe gedeelte wat die in kolom D moet weergeven moet er nog aan toegevoegd worden.

Heb ook als bijlage toegevoegd wat dan het resultaat zou moeten worden.

Hopelijk is het een beetje duidelijk zo.
 

Bijlagen

Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan