Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1448to1452
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Script erweitern mit auslesen von Spalten ohne Dup

Script erweitern mit auslesen von Spalten ohne Dup
25.09.2015 11:46:48
Spalten
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Script erweitern mit auslesen von Spalten ohne Dup
27.09.2015 13:51:12
Spalten
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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige