gegevens overnemen uit ander excelbestand

[enrico85]

Hallo allemaal,

Een tijd geleden heb ik op dit forum een goede vba code gekregen van iemand.
Deze code zoekt a.d.h.v. de gegevens op de factuur (geboortedatum, naam en datum prestatie) in de rapportage de juiste kostenplaats van de afdeling erbij.

Hieronder de 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
[COLOR="#FF0000"]  splits = Split("H:\Ziekenhuis facturen\rapportage labnotas\rapportage_oud.xlsx ", "\")[/COLOR]
  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("A1").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("Samenvatting").UsedRange.Columns("C").SpecialCells(xlConstants)  'loop alle namen af in je C-kolom
    If c.Row > 1 Then
      sNaam = c.Value
      dGeboorte = c.Offset(, -2).Value                     'geboortedatum staat 2 kolommen naar links
      dBegin = c.Offset(, 2).Value                         'begindatum staat 2 kolommen naar rechts
      c.Offset(, -1).Value = "201500"                      '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
       [COLOR="#FF0000"] If sn(l, 5) = dGeboorte And sn(l, 7) <= dBegin And (dBegin <= sn(l, 8) Or IsEmpty(sn(l, 8))) And InStr(1, sn(l, 2), Trim(sNaam), 1) Then  [/COLOR]'geboortedatum klopt, deel van de naam ook en valt binnen periode
        Select Case sn(l, 10)                                       'onderzoek de mogelijke waarden van sn(l,10)
  Case 403400 To 403470: c.Offset(, -1).Value = 434121      'ligt die hiertussen, dan schrijf je deze waarde weg
  Case 403720 To 403730: c.Offset(, -1).Value = 434103      '2e mogelijkheid, andere waarde wegschrijven
  Case 403740 To 403760: c.Offset(, -1).Value = 434101
  Case 403800 To 403870: c.Offset(, -1).Value = 434111
  Case 403900 To 403980: c.Offset(, -1).Value = 434135
  Case 405700 To 405770: c.Offset(, -1).Value = 454101
  Case 405800 To 405870: c.Offset(, -1).Value = 454111
  Case 405900 To 405970: c.Offset(, -1).Value = 454121
  Case 407640 To 407649: c.Offset(, -1).Value = 474141
  Case 407660 To 407669: c.Offset(, -1).Value = 474101
  Case 407730 To 407739: c.Offset(, -1).Value = 474103
  Case 407790 To 407799: c.Offset(, -1).Value = 474105
  Case 407810 To 407819: c.Offset(, -1).Value = 474111
  Case 407820 To 407829: c.Offset(, -1).Value = 474131
  Case 602140 To 602149: c.Offset(, -1).Value = 474121      
  Case 407830 To 407839: c.Offset(, -1).Value = 622281      
  Case 601100 To 602139: c.Offset(, -1).Value = 622281
  Case 602150 To 602599: c.Offset(, -1).Value = 622281
  Case 603200 To 603980: c.Offset(, -1).Value = 622284
  Case Else: c.Offset(, -1).Value = sn(l, 10)               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven
End Select
           Exit For                                         'spring uit de loop
        End If
       Next
       End If
  Next

End Sub

Nu is de rapportage het e.e.a. aangepast (zie bijlages rapportage nieuw en oud). Zoals ik zie, zijn er alleen wat kolommen bij gekomen en staan de nodige gegevens in andere kolommen.

Dus ik had de rood gearceerde regels in de code aangepast naar:

splits = Split("H:\Ziekenhuis facturen\rapportage labnotas\rapportage_[COLOR="#FF0000"]nieuw[/COLOR].xlsx ", "\")

If sn(l, [COLOR="#FF0000"]2[/COLOR]) = dGeboorte And sn(l, 7) <= dBegin And (dBegin <= sn(l, 8) Or IsEmpty(sn(l, 8))) And InStr(1, sn(l, [COLOR="#FF0000"]1[/COLOR]), Trim(sNaam), 1) Then

Maar nu geeft die dus bij deze laatst aangepaste regel de foutmelding "fout 9 tijdens uitvoering: Het subscript valt buiten het bereik".

Ik heb de factuur, rapportage nieuw en rapportage oud bijgevoegd in dit bericht. De code moet vanuit de factuur gedraaid worden.

Heeft iemand enig idee wat hier mis gaat?

Groeten
Enrico

 

[VenA]

Zorg ervoor dat de tabel in A1 begint.

sn = WB.Worksheets(1).Range("A1").CurrentRegion krijg nu niet de juiste waarde. Dit is eenvoudig te controleren door met <F8> door de code te wandelen.

 

[enrico85]

Hallo Ven A,

Bedankt voor je reactie.

Ik heb even zitten puzzelen maar ben erachter. Het kwam doordat er in de nieuwe rapportage een leger regel zat tussen regel 2 en 4. Dat regel 1 leeg is maakt in dit geval niet uit.

Heb je enig idee hoe ik deze code moet aanpassen als ik wil zoeken in meerdere tabbladen?
Hij pakt nu standaard de eerste tabblad (rapportage) maar kan je hieraan ook een naam geven of aangeven tabblad 1 en 3. De rapportage word binnenkort uitgebreid waardoor de code eerst moet zoeken in het eerst tabblad en hierna in het 2de of 3de tabblad.

Groet
Enrico