Script erweitern mit auslesen von Spalten ohne Dup

Bild

Betrifft: Script erweitern mit auslesen von Spalten ohne Dup
von: Chantal Zelder
Geschrieben am: 25.09.2015 11:46:48

Hallo zusammen
Ich habe vor einigen Monaten ein hübsches Werk erstellt. Das Script importiert sich aus einem Ordner diverse csv-Files und am Schluss wird mir eine Übersichtsseite generiert. Da sich die CSV-Files immer wieder Ändern wird mit dem ausführen des Scripts alles gelöscht und anschliessend neu eingelesen. Nun soll ich diese Übersichtsseite erweitern und ich komme nicht zum gewünschten Ergebnis.
Jedes Blatt, das in Excel eingelesen wird, erhält in der Übersicht eine eigene Zeile. Das Script zählt dabei in jedem dieser Blätter diverse Spalten mit Bedienungen zusammen. Da diese Statisch sind, war dies nie ein Problem. Neu habe ich zusätzlich eine Spalte R in diesen Blättern. Diese Spalte enthält inhomogene Daten. Somit soll nun für jedes Blatt aus der Spalte R die Werte ausgelesen werden ohne Duplikate und in der Overview sollen diese in der dazugehörigen Zeile zu diesem Blatt ausgegeben werden. anschliessend brauche ich zu jedem dieser Werte die Anzahl.
Aktuelles Script:


Sub ImportiereCSVDateien()
    Const CSVPFAD = "C:\temp\lyncrollout"
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet
    Set fso = CreateObject("Scripting.Filesystemobject")
    Set wbTarget = ActiveWorkbook
    Application.DisplayAlerts = False
    'Lösche alle Worksheets bevor wir alle neu anlegen
    If wbTarget.Worksheets.Count > 1 Then
        For i = 1 To wbTarget.Worksheets.Count - 1
            wbTarget.Worksheets(i).Delete
        Next
    End If
    For Each f In fso.GetFolder(CSVPFAD).Files
        If LCase(Right(f.Name, 3)) = "csv" Then
            Workbooks.OpenText Filename:=f.Path
            Set wbSource = ActiveWorkbook
            On Error Resume Next
            Set ws = wbTarget.Worksheets(f.Name)
            If Err <> 0 Then
                Set ws = wbTarget.Worksheets.Add
                ws.Name = f.Name
                ws.Range("A:ZZ").Clear
            End If
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:= _
True, TrailingMinusNumbers:=True
            wbSource.Worksheets(1).Range("A:AE").Copy Destination:=ws.Range("A1")
            wbSource.Close False
        End If
    Next
    Application.DisplayAlerts = True
    Set fso = Nothing
    
    
    
Dim tbl As ListObject
    
    For i = 1 To ActiveWorkbook.Sheets.Count
     Sheets(i).Select
     
    Dim loeschen As Double
    For loeschen = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
    If Cells(loeschen, 21).Value = "" Then
    Rows(loeschen).Delete
    End If
    Next loeschen
    
     Range("A1:AA" & Cells(Rows.Count, 1).End(xlUp).Row).Select
     Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
     tbl.TableStyle = "TableStyleLight1"
     
     
     Rows("1:1").Select
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     Range("A1").Select
     ActiveCell.FormulaR1C1 = "Home"
     Range("A1").Select
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "Overview!A1", TextToDisplay:="Home"
        
    Next i
    
 
Dim Tabelle As Worksheet
Dim t As Integer
Worksheets.Add.Move before:=Worksheets(1)
ActiveSheet.Name = "Overview"
Cells(1, 1).Value = "Enthaltene Blätter"
t = 3
For Each Tabelle In ActiveWorkbook.Worksheets
If Tabelle.Name <> "Overview" Then
Cells(i, 2).Value = Tabelle.Name
Tabelle.Hyperlinks.Add Anchor:=Cells(i, 2), Address:="", SubAddress:= _
Tabelle.Name & "!A1", _
TextToDisplay:=Tabelle.Name
i = i + 1
End If
Next Tabelle
For nRow = 5 To 300
    Cells(nRow, 4).Formula = "=COUNTIF('" & Cells(nRow, 2).Value & "'!C[21],""sip:*"")"
    Cells(nRow, 6).Formula = "=COUNTIF('" & Cells(nRow, 2).Value & "'!C[18],""tel:*"")"
    Cells(nRow, 3).Formula = "=(COUNTA('" & Cells(nRow, 2).Value & "'!A:A))-2"
    Cells(nRow, 5).Formula = "=100/RC[-2]*RC[-1]"
    Cells(nRow, 7).Formula = "=100/RC[-4]*RC[-1]"
Next nRow
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Site"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "User"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "Lync Phase 1"
    Range("E3").Select
    ActiveCell.FormulaR1C1 = "in Prozent"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "Lync Phase 2"
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "in Prozent"
    Range("B3:G3").Select
    Selection.Font.Bold = True
    
    Range("E4:E96").Select
    Selection.NumberFormat = "0.00"
    Range("G4:G96").Select
    Selection.NumberFormat = "0.00"
    
    Range("E4").Select
    Selection.FormatConditions.AddDatabar
    Selection.FormatConditions(Selection.FormatConditions.Count).ShowValue = True
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
        .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
    End With
    With Selection.FormatConditions(1).BarColor
        .Color = 13012579
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).BarFillType = xlDataBarFillGradient
    Selection.FormatConditions(1).Direction = xlContext
    Selection.FormatConditions(1).NegativeBarFormat.ColorType = xlDataBarColor
    Selection.FormatConditions(1).BarBorder.Type = xlDataBarBorderSolid
    Selection.FormatConditions(1).NegativeBarFormat.BorderColorType = _
        xlDataBarColor
    With Selection.FormatConditions(1).BarBorder.Color
        .Color = 13012579
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).AxisPosition = xlDataBarAxisAutomatic
    With Selection.FormatConditions(1).AxisColor
        .Color = 0
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).NegativeBarFormat.Color
        .Color = 255
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).NegativeBarFormat.BorderColor
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.AutoFill Destination:=Range("E4:E104"), Type:=xlFillDefault
    Range("E4:E96").Select
    Range("G4").Select
    Selection.FormatConditions.AddDatabar
    Selection.FormatConditions(Selection.FormatConditions.Count).ShowValue = True
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
        .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
    End With
    With Selection.FormatConditions(1).BarColor
        .Color = 13012579
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).BarFillType = xlDataBarFillGradient
    Selection.FormatConditions(1).Direction = xlContext
    Selection.FormatConditions(1).NegativeBarFormat.ColorType = xlDataBarColor
    Selection.FormatConditions(1).BarBorder.Type = xlDataBarBorderSolid
    Selection.FormatConditions(1).NegativeBarFormat.BorderColorType = _
        xlDataBarColor
    With Selection.FormatConditions(1).BarBorder.Color
        .Color = 13012579
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).AxisPosition = xlDataBarAxisAutomatic
    With Selection.FormatConditions(1).AxisColor
        .Color = 0
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).NegativeBarFormat.Color
        .Color = 255
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).NegativeBarFormat.BorderColor
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.AutoFill Destination:=Range("G4:G104"), Type:=xlFillDefault
    Range("G4:G104").Select
    
    Range("H4").Select
    ActiveCell.FormulaR1C1 = _
    "=VLOOKUP(RC[-6],'[Stammdaten Lokationen.xlsx]Tabelle1'!R1C1:R20C13,2,FALSE)"
    Selection.AutoFill Destination:=Range("H4:H104"), Type:=xlFillDefault
    Range("H4:H104").Select
    ActiveWindow.SmallScroll Down:=-72
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "Firma"
    Range("H4").Select
End Sub

Hat jemand verstanden von was ich spreche und was ich benötige?
Rumprobiert habe ich mit foglendem Code:

Private Sub Worksheet_Activate()
 
    Dim i As Long
    Dim oDict As Object
 
    Set oDict = CreateObject("scripting.dictionary")
    Const intZ = 4
 
    With Worksheets("086SHN_MET.csv")
        For i = 3 To .Cells(Rows.Count, 18).End(xlUp).Row
        If Len(Trim(.Cells(i, 18))) Then oDict(.Cells(i, 18).Text) = ""
        Next i
    End With
 
    Worksheets("Overview").Cells(intZ, 9).Resize(oDict.Count, 1) = Application.Transpose(oDict.  _
_
keys)
    
    
     Range("I4:I80").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("J4").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("I4:I80").Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

Aber Damit komme ich nur zu einer Befüllung von Spalten für ein einziges Blatt.
Gruss
Chantal

Bild

Betrifft: AW: Script erweitern mit auslesen von Spalten ohne Dup
von: fcs
Geschrieben am: 27.09.2015 13:51:12
Hallo Chantal,
probiere es mal mit folgender Anpassung
Gruß
Franz

    Range("H3").Select
    ActiveCell.FormulaR1C1 = "Firma"
    Call WeitereAuswertung  'neue Zeile
End Sub
Private Sub WeitereAuswertung()
    Dim Zeile As Long
    Dim strBlatt As Long
    Dim wksOV As Worksheet, wks As Worksheet
    Dim i As Long
    Dim oDict As Object
    Const SpaBlatt As Long = 2  'SPalte mit Blattnamen im Blatt "Overview" -ggf. anpassen
    
    Set wksOV = ActiveWorkbook.Worksheets("Overview")
    
    For Zeile = 4 To wksOV.Cells(wksOV.Rows.Count, SpaBlatt).End(xlUp).Row
        strBlatt = .Cells(Zeile, SpaBlatt).Text
        If strBlatt <> "" Then
            Set oDict = CreateObject("scripting.dictionary")
           
            With Worksheets(strBlatt)
                For i = 3 To .Cells(Rows.Count, 18).End(xlUp).Row
                    If Len(Trim(.Cells(i, 18))) Then oDict(.Cells(i, 18).Text) = ""
                Next i
            End With
    
            With wksOV
                .Cells(Zeile, 9).Resize(oDict.Count, 1) = _
                    Application.Transpose(oDict.keys)
       
       
                .Range(.Cells(Zeile, 9).Cells(Zeile + 76, 9)).Copy
                .Cells(Zeile, 10).PasteSpecial Paste:=xlPasteAll, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                    
                Application.CutCopyMode = False
                .Range(.Cells(Zeile, 9).Cells(Zeile + 76, 9)).ClearContents
            End With
            Set oDict = Nothing
        End If
    Next Zeile
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Script erweitern mit auslesen von Spalten ohne Dup"