Komplexer Datensatz CSV in einfache Filterstruktur umwandeln

[retwa]

Guten Tag

Ich habe eine Testdatensatz. Dieser ist nicht in Spalten geordnet sondern immer vor dem Testresultat steht eine "Testbeschreibung". Teilweise auch Retestdaten, welche einfach anschliessend nochmals angefügt wurden. Mit Pivot schein ich nicht ans Ziel zu kommen. Ich möchte das ganze in eine einfach Filtertabelle umwandeln.

Könnt ihr mit bitte einen Tipp geben wie ich das hinbekommen könnte. Ggf. Anweisungen, Tutorials etc.

Bitte schaut euch das Attachment an.

Herzlichen Dank.

[WillWissen]

Hi,

erstelle bitte eine Beispieldatei, in der du ein paar Wunschergebnisse händisch einträgst.

[Der Steuerfuzzi]

Hallo,

ich könnte mir vorstellen, dass das mit PowerQuery funktionieren könnte.

[retwa]

An bei die geforderte Datei, hoffe stimmt so. Sonst bitte nochmals melden.

Das mit dem PowerQuery, werde ich mich einlesen.

[snb]

Code:

Sub M_snb()
  sn = Split(CreateObject("scripting.filesystemobject").opentextfile("G:\OF\__csv.txt").readall, vbCrLf)
    
  For j = 0 To UBound(sn) - 1
    st = Split(sn(j), ",")
    If j = 0 Then
      ReDim sp(UBound(sn) + 1, UBound(st))
      For jj = 3 To UBound(st) Step 2
        sp(0, 2 + jj \ 2) = st(jj)
      Next
    End If
    sp(j + 1, 0) = st(0)
    sp(j + 1, 1) = st(1)
    sp(j + 1, 2) = st(2)
    For jj = 4 To UBound(st) Step 2
      sp(j + 1, 2 + jj \ 2 - 1) = st(jj)
    Next
  Next
    
  Sheet1.Cells(1).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub

[Jockel]

...

Das mit dem PowerQuery, werde ich mich einlesen.

Hallo, ja mach das... Kann das sein, dass deine csv keine Überschrift(en) hat..?

[retwa]

Code:

Sub M_snb()
  sn = Split(CreateObject("scripting.filesystemobject").opentextfile("G:\OF\__csv.txt").readall, vbCrLf)
    
  For j = 0 To UBound(sn) - 1
    st = Split(sn(j), ",")
    If j = 0 Then
      ReDim sp(UBound(sn) + 1, UBound(st))
      For jj = 3 To UBound(st) Step 2
        sp(0, 2 + jj \ 2) = st(jj)
      Next
    End If
    sp(j + 1, 0) = st(0)
    sp(j + 1, 1) = st(1)
    sp(j + 1, 2) = st(2)
    For jj = 4 To UBound(st) Step 2
      sp(j + 1, 2 + jj \ 2 - 1) = st(jj)
    Next
  Next
    
  Sheet1.Cells(1).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub

Vielen Dank für den VBA Code. Ich denke das ist der Weg den ich gehen muss. Dein Code macht schon vieles Richtig. Leider berücksichtig er nicht, dass unterschiedliche Produkte nicht alle Spalten haben. Des weiteren auch gleiche Tests (Testwiederholungen) Zusätzlich dargestellt werden müssten.

Ich werde darauf aufbauen oder PowerQuery weiter vertiefen.

Merci

[retwa]

Hallo, ja mach das... Kann das sein, dass deine csv keine Überschrift(en) hat..?

Richtig. Das ist ja die "Schwäche" resp. das Problem. Ein Problem von vielen.

[WillWissen]

Hi,

Richtig. Das ist ja die "Schwäche" resp. das Problem. Ein Problem von vielen.

kennst du den Ersteller der csv-Datei? Dann wäre es vllt. der einfachste Weg, dich mit der Person in Verbindung zu setzen und um Spaltenbezeichnungen zu bitten.

[Kuwer]

Hallo retwa,

teste es mal mit folgendem Code:

Modul Modul5

Option Explicit 

Sub ImportCSV() 
 Dim i As Long, j As Long, k As Long 
 Dim rngQ As Range, rngT As Range 
 Dim varT As Variant, varQ As Variant, varZ As Variant 
  
 Application.ScreenUpdating = False 
  
 Workbooks.OpenText Filename:="C:\Users\Kuwer\Documents\Excel\Test\csv.txt", _
   Origin:=1252, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
   ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False 
    
 Set rngQ = ActiveSheet.Cells(1).CurrentRegion 
 rngQ.Cells(1).Offset(rngQ.Rows.Count + 1) = "..." 
 For i = 1 To rngQ.Rows.Count 
   For j = 4 To rngQ.Columns.Count Step 2 
     If Len(rngQ(i, j).Value) Then 
       If Not rngT Is Nothing Then 
         If rngQ(i, j).Value = rngQ(i, j - 2).Value Then 
           k = k + 1 
           rngQ(i, j).Value = rngQ(i, j).Value & String(k, " ") 
         Else 
           k = 0 
         End If 
         Set rngT = Application.Union(rngT, rngQ(i, j)) 
       Else 
         Set rngT = rngQ(i, j) 
       End If 
     Else 
       k = 0 
       Exit For 
     End If 
   Next j 
   If Not rngT Is Nothing Then 
     rngT.Copy 
     rngQ.Parent.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Transpose:=True 
     Set rngT = Nothing 
   End If 
 Next i 
 rngQ.Replace "...", "" 
 varQ = rngQ.Value 
 rngQ(1, 1).Value = "Product" 
 rngQ(1, 2).Value = "Date" 
 rngQ(1, 3).Value = "Time" 
 With rngQ.Parent.Cells(Rows.Count, 1).End(xlUp).CurrentRegion 
   .RemoveDuplicates Columns:=1, Header:=xlNo 
   .Replace "...", "" 
   .Sort Key1:=.Cells(1), Order1:=xlAscending 
   .Copy 
   rngQ(1, 4).PasteSpecial Transpose:=True 
   .EntireRow.Delete 
 End With 
 Redim varZ(1 To Ubound(varQ, 1), 1 To Application.Min(Columns.Count - 3, Ubound(varQ, 1) * Ubound(varQ, 2))) 
 For i = 1 To Ubound(varQ, 1) 
   varZ(i, 1) = varQ(i, 1) 
   varZ(i, 2) = varQ(i, 2) 
   varZ(i, 3) = varQ(i, 3) 
   For j = 4 To Ubound(varQ, 2) Step 2 
     If Len(varQ(i, j)) Then 
       varZ(i, Application.Match(varQ(i, j), rngQ.Rows(1), 0)) = varQ(i, j + 1) 
     Else 
       Exit For 
     End If 
   Next j 
 Next i 
 With rngQ 
   .Rows(.Rows.Count).Copy 
   .Rows(.Rows.Count + 1).PasteSpecial -4122 
   .Cells(2, 1).Resize(Ubound(varQ, 1), Ubound(varQ, 2)).Value = varZ 
   .Cells(1).Select 
 End With 
 Application.CutCopyMode = False 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Gruß Uwe