Importeren data uit een bestand met vreemde indeling

[namruuh]

Ik heb een bestand met > 1000 records aangeleverd gekregen in het formaat zoals in de bijlage, en ik wil deze in Excel importeren. Hoe krijg ik dit voor elkaar? Ieder record is onder elkaar opgeslagen (ik weet niet hoe ik dit beter kan verwoorden), maar ik wil dit in een formaat hebben dat ik kan gebruiken voor draaitabellen.
Bekijk bijlage voorbeeld1.xls

 

[Elsendoorn2134]

namruuh,

Wat je als voorbeeld hebt gestuurd is een uitdraai van een log bestand van waarschijnlijk een factureringsprogramma.
Ik stel voor dat je naar de verantwoordelijke IT medewerker gaat en een kopie vraagt van de database of een
deel hiervan in Excel.
De gegevens in het overzicht gaat over de facturen die uitgeprint zijn, er staat niets in over de waarde van de
bedragen die op de facturen staan. Tenzij je het aantal facturen per uur wil weten heb je hier dus helemaal niets aan.

Veel Succes.

 

[namruuh]

Nee, ik heb de data aangepast, maar het zijn geen facturen. Het is ook niet relevant wat het is, ik wil het analyseren

 

[cow18]

zie bijlage

 

[namruuh]

Briljant bedacht, hier kan ik mee verder! Dankjewel!

edit: dat is jammer, het blijkt dat het aantal rijen per record variabel is; meestal 14, maar soms ook 15 of 16, zie nieuwe bijlage. Ik heb geprobeerd jouw formules hier op aan te passen, maar het blijft scheef lopen

Bekijk bijlage Voorbeeld2.xls

 

[cow18]

zie bijlage

 

[namruuh]

Dit gaat mij boven mijn pet... Hij doet het bijna helemaal, hij lijkt de waarden bij POLIS_NUMMER niet mee te nemen in de tabel. Die zijn ook niet bij ieder record aanwezig, maar hij laat ze nu niet zien. Ik snap te weinig van VBA om te vinden waar ik iets moet aanpassen...

 

[cow18]

Sub MaakTabel()
  Dim sn, i As Long, Arr(), Dict As Object, i1 As Integer
  Dim vKolom1
  vKolom1 = Array("Aspect: _MDMS_CREATION_DATE", "Aspect: _MDMS_DOCID", "Aspect: _MDMS_TITLE", "Aspect: _MDMS_TYPE", "Aspect: COMPANY_CODE", "Aspect: CONTRACT_NUMMER", "Aspect: DOCUMENT_BRON", "Aspect: DOCUMENT_GROEP", "Aspect: DOCUMENT_NAAM", "Aspect: NOTA_NUMMER", "Aspect: PRINT_DATUM", "Aspect: PUBLICEREN", "Aspect: REKENINGCOURANT_NR", "Aspect: SUB_DOC_NAAM", "Aspect: BATCH_ID", "Aspect: POLIS_NUMMER")

  Set Dict = CreateObject("scripting.dictionary")
  sn = Sheets("blad2").Range("A1").CurrentRegion           'lees je gegevens in
  ReDim Arr(1 To 1, 1 To 1)                                'voorlopige dimensie
  With Dict                                                'je dictionary
    For i = 1 To UBound(sn)                                '1 voor 1 je gegevens aflopen
      Select Case Split(sn(i, 1), ":")(0)                  'wat staat er in de 1e kolom voor het dubbelpunt
        Case "Title"
          If UBound(Arr, 2) = UBound(vKolom1) + 3 Then .Item(.Count) = Arr  'had je al een geldige arr, schrijf die weg naar dictionary
          ReDim Arr(1 To 1, 1 To UBound(vKolom1) + 3)      'arr opnieuw dimensioneren
          Arr(1, 1) = Mid(sn(i, 1), InStr(1, sn(i, 1), ":", 1) + 1)  'title wegschrijven
        Case "Type"                                        'niets doen
        Case "Time": Arr(1, UBound(Arr, 2)) = Mid(sn(i, 1), InStr(1, sn(i, 1), ":", 1) + 1)  'gedeelte na dubbelpunt wegschrijven naar laatste element van arr
        Case "Aspect"
          On Error Resume Next
          i1 = 0: i1 = WorksheetFunction.Match(Trim(sn(i, 1)), vKolom1, 0)  'welk kenmerk ?
          On Error GoTo 0
          If i1 > 0 Then
          Arr(1, i1 + 1) = Trim(Mid(sn(i, 2), 7))  'wegschrijven naar arr
      Else
      MsgBox "onbekend kenmerk, niet in vkolom1 : " & sn(i, 1)
      End If
      End Select
    Next
    .Item(.Count) = Arr                                    'allerlaatste ook wegschrijven naar dictionary
  End With

  With Sheets("blad2").Range("D1")                         'bereik waar naar toe geschreven wordt
    .Resize(, UBound(Arr, 2) + 1).EntireColumn.ClearContents  'kolommen leegmaken
    .Resize(, UBound(vKolom1) + 3).Value = Split(Replace("Title" & vbLf & Join(vKolom1, vbLf) & vbLf & "Time", "Aspect: ", ""), vbLf) 'koppen erboven zetten
    .Offset(1).Resize(Dict.Count, UBound(Arr, 2)).Value = Application.Index(Dict.items, 0, 0)  'wegschrijven
    .Resize(, UBound(Arr, 2)).EntireColumn.AutoFit         'kolombreedte
  End With
End Sub

 

[pixcel]

Misschien is dit een beetje beter te begrijpen. De "zelflerende" tabel staat op blad2.

 

[cow18]

@Frans,
dat declareren "as Excel.ListColumn" en "as Excel.listobject" , zit er daar verschil op dan te declareren "as Listcolumn" en "as Listobject" dus zonder die "Excel." of is dat om ergens je af te zetten tegen Access ?

 

[pixcel]

@Frans,
dat declareren "as Excel.ListColumn" en "as Excel.listobject" , zit er daar verschil op dan te declareren "as Listcolumn" en "as Listobject" dus zonder die "Excel." of is dat om ergens je af te zetten tegen Access ?

Nee en nee. Deze objecten kunnen geen verwarring geven. Maar Open eens de vbe, en maak in Extra een verwijzing naar Word. Type dan in het direct venster of in een procedure "dim r as r". Welke moet je nu hebben?
Kwalificeren is een good practice. Na verloop van tijd een automatisme.

 

[cow18]

dank je voor de uitleg, ik ben een zuivere excel-adept, dus zijsprongetjes naar Word, Outlook of Access doe ik uiterst zelden.
Toch zal ik het proberen te onthouden en toe te passen.