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