trim gegevens in kolom

enrico85 · 6 jun 2016

Hallo allemaal,

Ik wil voordat die de gegevens naar een array leest, dat die kolom A gaat trimmen. Op deze manier wil ik de speciale tekens die in de namen voorkomen verwijderen.

Weet iemand hoe ik dit moet toepassen in onderstaande 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("H:\ziekenhuis facturen\rapportage labnotas\rapportage_nieuw.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

Ik vermoed dat er dan nog een stukje code moet komen tussen regel 13 en 14.

Hoor het graag.

Groet
Enrico

snb · 6 jun 2016

Welke speciale tekens ?

Deze code is vooralsnog genoeg:

Code:

with getobject("H:\ziekenhuis facturen\rapportage labnotas\rapportage_nieuw.xlsx")
     .visible=true
     sn = .sheets(1).Range("A4").CurrentRegion
  end with

PS. het is slim om in padnamen spaties te vermijden.

enrico85 · 6 jun 2016

Het gaat met name om de trema's ë, ö etc.

Moet ik deze code tussen regel 13 en 14 zetten?

edmoor · 6 jun 2016

"Trimmen" heeft niets met speciale tekens te maken.
Je wilt ë vervangen door e en ö door o etc?

snb · 6 jun 2016

Ik denk dat het goed is eens de basisbeginselen van VBA je eigen te maken; dan snap je onze reakties/suggesties ook iets beter en kun je je vragen ook beter onder woorden brengen..

Warme bakkertje · 7 jun 2016

Iets in deze zin.

Code:

    For Each v In Array("/", "\", "|", ":", "*", "?", "<", ">", """", "'")
        TextBox3.Text = Replace(TextBox3.Text, v, "_")
    Next

edmoor · 7 jun 2016

Of deze functie:

Code:

Function Ascii127(Regel As String) As String
    Dim i As Integer
    Const Chars255 = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const chars127 = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
    For i = 1 To Len(Chars255)
        Regel = Replace(Regel, Mid(Chars255, i, 1), Mid(chars127, i, 1))
    Next
    Ascii127 = Regel
End Function

Aanroep:
TextBox3.Text = Ascii127(TextBox3.Text)

enrico85 · 7 jun 2016

Ik wil inderdaad de speciale tekens verwijderen, dacht dat trimmen hiervoor de oplossing zou zijn maar dat is dus niet zo.
Ben een leek op dit gebied, zou mooi zijn om de basisbeginselen van VBA een beetje onder de knie te krijgen zodat ik het beter onder woorden kan brengen. Maar helaas nog geen tijd voor gehad of niet de goed boeken gevonden.

Heb nu de volgende code geprobeerd:

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("H:\ziekenhuis facturen\rapportage labnotas\rapportage_nieuw.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 Each v In Array("/", "\", "|", ":", "*", "?", "<", ">", """", "'")
        TextBox3.Text = Replace(TextBox3.Text, v, "_")
    Next
   
  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 1 kolom 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
    If sn(l, 2) = dGeboorte And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) And InStr(1, sn(l, 1), Trim(sNaam), 1) 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) kostenplaats

  Case Else: c.Offset(, -1).Value = sn(l, 8)               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven kolom kostenplaats
End Select
           Exit For                                         'spring uit de loop
        End If
       Next
       End If
  Next


End Sub

Helaas geeft die dan de melding: fout 424 tijdens uitvoering: object vereist

edmoor · 7 jun 2016

Als ik zie wat je hebt gedaan en je dan afvraagt waarom het niet werkt kan ik alleen maar concluderen dat je ook de basiskennis nog niet hebt. Het enige dat naar mijn mening hier helpt is dat je je document plaatst en dat iemand van ons het er voor je inbouwt. Het is niet negatief bedoeld maar wat je wilt doen is echt nog te hoog gegrepen en wil ik met alle plezier bij helpen in het eigenlijke document.

Het zal dan in ieder geval al goed werken en wellicht dat een stukje uitleg per regel in de code je direct vooruit helpt wat betreft VBA kennis.

snb · 7 jun 2016

niet gezocht, toch gevonden:

https://www.bol.com/nl/p/vba-voor-dummies/1001004005510771/

enrico85 · 7 jun 2016

Ik zal morgen de hele code plaatsen en voorbeelden. Helaas kan ik niet de originele bestanden plaatsen, deze zijn erg groot en bevatten gevoelige informatie.
Verder wil ik ook nog eigenlijk een aantal andere dingen proberen te veranderen. Dit zal ik dan ook proberen uit te leggen en hopelijk kunnen jullie me hiermee verder helpen.
Maar als de speciale tekens uit de naam verwijderd kunnen worden voordat de rapportage naar de array word gelezen ben ik al erg geholpen.

enrico85 · 8 jun 2016

Hieronder de hele code:

Code:

Sub RIVIERENLAND_ZGV_KPL_OPZOEKEN_NIEUW_TEST()
'
' RIVIERENLAND_ZGV_KPL_OPZOEKEN_NIEUW Macro
'
Sheets("Samenvatting").Select
    Columns("A:G").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Select
    Selection.Cut
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("J:J").Select
    Selection.Cut
    Columns("B:B").Select
    ActiveSheet.Paste
    Columns("M:M").Select
    Selection.Cut
    Columns("C:C").Select
    ActiveSheet.Paste
    Columns("O:O").Select
    Selection.Cut
    Columns("D:D").Select
    ActiveSheet.Paste
    Columns("P:P").Select
    Selection.Cut
    Columns("E:E").Select
    ActiveSheet.Paste
    Columns("U:U").Select
    Selection.Cut
    Columns("F:F").Select
    ActiveSheet.Paste
    Columns("I:I").Select
    Selection.Cut
    Columns("G:G").Select
    ActiveSheet.Paste
    Columns("H:Z").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.LargeScroll ToRight:=-1
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "GEBOORTEDATUM"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "KOSTENPLAATS"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "NAAM"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "CODE PRESTATIE"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "DATUM PRESTATIE"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "KOSTEN"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "BSN"
    Columns("A:G").Select
    Columns("A:G").EntireColumn.AutoFit
 
  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("H:\ziekenhuis facturen\rapportage labnotas\rapportage_nieuw.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("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 1 kolom 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
        If sn(l, 2) = dGeboorte And sn(l, 5) <= dBegin And (dBegin <= sn(l, 6) Or IsEmpty(sn(l, 6))) And InStr(1, sn(l, 1), Trim(sNaam), 1) 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) kostenplaats
  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      'Langeberg 4&5 van RVE MCZN naar RVE Nijmegen
  Case 407830 To 407839: c.Offset(, -1).Value = 622281      'brug eikstraat van RVE Nijmegen naar RVE MCZN
  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, 8)               'in alle andere gevallen, de oorspronkelijke waarde wegschrijven kolom kostenplaats
End Select
           Exit For                                         'spring uit de loop
        End If
       Next
       End If
  Next
 
Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],2)"
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E20000")
    Range("E:E").Select
    Columns("E:E").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "CODE PRESTATIE"
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
                                                           
    Cells.Select                                            'autofilter op tabblad samenvatting toegevoegd
    Selection.autofilter
 
Cells.Select
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Samenvatting!R1C1:R1048576C6", Version:=xlPivotTableVersion14). _
        CreatePivotTable TableDestination:="Blad1!R3C1", TableName:="Draaitabel1", _
        DefaultVersion:=xlPivotTableVersion14
    Sheets("Blad1").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("KOSTENPLAATS")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("GEBOORTEDATUM")
        .Orientation = xlRowField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("NAAM")
        .Orientation = xlRowField
        .Position = 3
    End With
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("CODE PRESTATIE")
        .Orientation = xlRowField
        .Position = 4
    End With
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("DATUM PRESTATIE")
        .Orientation = xlRowField
        .Position = 5
    End With
    ActiveSheet.PivotTables("Draaitabel1").AddDataField ActiveSheet.PivotTables( _
        "Draaitabel1").PivotFields("KOSTEN"), "Aantal van KOSTEN", xlCount
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("KOSTENPLAATS").LayoutForm _
        = xlTabular
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("KOSTENPLAATS"). _
        LayoutBlankLine = True
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("GEBOORTEDATUM")
        .LayoutBlankLine = True
        .LayoutForm = xlTabular
    End With
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("NAAM").Subtotals = Array( _
        False, False, False, False, False, False, False, False, False, False, False, False)
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("NAAM").LayoutForm = _
        xlTabular
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("CODE PRESTATIE").Subtotals _
        = Array(False, False, False, False, False, False, False, False, False, False, False, False _
        )
    ActiveSheet.PivotTables("Draaitabel1").PivotFields("CODE PRESTATIE"). _
        LayoutForm = xlTabular
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("Aantal van KOSTEN")
        .Caption = "Som van KOSTEN"
        .Function = xlSum
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.31496062992126)
        .RightMargin = Application.InchesToPoints(0.31496062992126)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
       .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    Sheets("Blad1").Select
    Sheets("Blad1").Name = "Bijlage factuur"
    With ActiveSheet.PivotTables("Draaitabel1").PivotFields("KOSTENPLAATS")
        .PivotItems("(blank)").Visible = False
    End With
    
    Columns("F:F").Select
    Selection.Style = "Currency"
   
End Sub

Het begin en einde van de code heb ik er zelf een beetje bij geplakt met macro's opnemen etc. Dit zal er ongetwijfeld amateuristisch uitzien

Maar de aanpassingen moeten gebeuren in het middelste gedeelte (het gedeelte wat ik al eerder heb gepost).

Zover ik deze code een beetje begrijp doet die het volgende (begin en einde van de code weggelaten):

Het 1ste tabblad van de rapportage word gelezen naar een array. Vervolgens Zoekt die vanuit het actieve werkblad in het tabblad "samenvatting" van de factuur naar een match met de rapportage. Dit doet die op basis van geboortedatum + gedeelte naam en datum prestatie. Als die een match heeft gevonden in de rapportage neemt die de celwaarde over uit kolom H van de rapportage en zet dit in de factuur (tabblad samenvatting kolom B)

Nu wil ik eigenlijk dat die het volgende gaat doen:

beide tabbladen van de rapportage lezen naar een array en voordat die dit doet de speciale tekens verwijderen uit de namen in beide tabbladen (kolom A) . Ook moet die de tijdnotaties uit kolom E en F verwijderen.

Vervolgens wil ik dat die eerst naar de prestatiecode kijkt.

Als prestatie code begint met 07 (factuur, tabblad samenvatting kolom D) dan:

Zoek in rapportage, tabblad Klinisch naar een match op basis van BSN + geboortedatum en datum prestatie. Vind die een match neem celwaarde in kolom H uit rapportage, tabblad Klinisch over en zet dit in factuur, tabblad samenvatting kolom B. Vind die geen match zoek dan op basis van geboortedatum + gedeelte naam en datum prestatie.

Vind die geen match dan moet die dit herhalen in tabblad Ambulant. Als die een match heeft in dit tabblad dan moet die waarden "201500" weergeven in factuur, tabblad samenvatting kolom B.

Mocht die hierna nog geen match hebben gevonden geef dan waarde "Niet gevonden" in kolom B.

Bij alle overige prestatiecodes:

Zoek in rapportage, tabblad Klinisch naar een match op basis van BSN + geboortedatum en datum prestatie. Vind die een match neem celwaarde in kolom H uit rapportage, tabblad Klinisch over en zet dit in factuur, tabblad samenvatting kolom B en voeg hieraan toe " (niet lab)". Vind die geen match zoek dan op basis van geboortedatum + gedeelte naam en datum prestatie.

Vind die geen match dan moet die dit herhalen in tabblad Ambulant. Vind die hiermee een match neem dan ook celwaarde in kolom H uit rapportage, tabblad Klinisch over en zet dit in factuur, tabblad samenvatting kolom B en voeg hieraan toe " (niet lab)".

Mocht die hierna nog geen match hebben gevonden geef dan waarde "Niet gevonden" in kolom B.

Hierbij voorbeelden van de factuur en rapportage. In werkelijkheid zijn deze bestanden veel groter.

Hopelijk heb ik het een beetje duidelijk uitgelegd wat de bedoeling is en anders hoor ik het graag.

Alvast bedankt.

edmoor · 8 jun 2016

Als dat werkt zoals je wil dan blijf ik er angstvallig vanaf. In het document rapportage heb ik mijn voorstel uit #7 verwerkt. Druk op de knop "Bewerk de namen" om het wijzigen van de namen uit te voeren.

Je document:
Bekijk bijlage rapportage.xlsm

Die voorbeeld meneer van regel 13 komt uit Polen

enrico85 · 8 jun 2016

Helaas werkt die nog niet zoals ik wil. Ik wil dat die in eerste instantie op BSN gaat zoeken en als bevestiging de geboortedatum. Vervolgens op geboortedatum met bevestiging gedeelte van de naam en ook dat die personen eruit haalt die zoiezo niet in de rapportage voorkomen. Dit doet die namelijk nu niet. Kan het eigenlijk wel wat ik uiteindelijk wil of is dat te complex?

Jouw manier voor de speciale tekens werkt wel, zelf op die meneer uit Polen

Maar kan ik dit ook in de code verwerken voordat die de rapportage naar de array zet?

edmoor · 8 jun 2016

Je initiële vraag was het wijzigen van de speciale tekens en dat is precies wat mijn functie doet. In dat bijgesloten document kan je heel simpel zien hoe deze moet worden aangeroepen. Plaats dus die functie in een module van je eigen document en roep deze aan waar je het in je eigen code nodig vind.

enrico85 · 8 jun 2016

Ik ga er mee aan de slag en voor het zoeken met meerdere zoekopdrachten zal ik wel even een nieuwe post plaatsen.

Bedankt voor je hulp in ieder geval.

trim gegevens in kolom

enrico85

Gebruiker

snb

Verenigingslid

enrico85

Gebruiker

edmoor

Inventaris

snb

Verenigingslid

Warme bakkertje

Meubilair

edmoor

Inventaris

enrico85

Gebruiker

edmoor

Inventaris

snb

Verenigingslid

enrico85

Gebruiker

enrico85

Gebruiker

Bijlagen

edmoor

Inventaris

enrico85

Gebruiker

edmoor

Inventaris

enrico85

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy