Re: Hier der Code
25.03.2003 10:00:57
Jürgen
Hallo ForumWie gewünscht hier der VBA Code.
Gruss und Herzlichen Dank im Voraus
Jürgen
Sub Auswerten_Tabellenblätter()
Dim arrFiles As Variant
Dim intcounter As Integer, intRow As Integer
Dim strpath As String
Dim wkb As Workbook
Dim wkb_name As String
Dim wks_Original As Worksheet
Dim wks_Kopie As Worksheet
Dim wks_Auswertung As Worksheet
Dim loaded As Boolean
strpath = GetDirectory("Bitte Ordner der Quelldateien auswählen:")
If strpath = "" Then Exit Sub
'Ermitteln der vorhandenen EXCEL Arbeitsmappen '
ChDir strpath
arrFiles = FileArray(strpath, "*.xls", "a")
intRow = 1
For intcounter = 1 To UBound(arrFiles)
Workbooks.Open strpath & arrFiles(intcounter)
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Kopie").Delete
Worksheets("Auswertung").Delete
Application.DisplayAlerts = True
Set wks_Original = ActiveWorkbook.Sheets(1)
With ActiveWorkbook
.Worksheets(1).Copy after:=.Worksheets(.Worksheets.Count)
End With
ActiveSheet.Name = ("Kopie")
Set wks_Kopie = ActiveWorkbook.Sheets(2)
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ("Auswertung")
Set wks_Auswertung = ActiveWorkbook.Sheets(3)
wks_Kopie.Activate
Call Filtern_Identnummer_Häufigkeit
ActiveWorkbook.Close savechanges:=True
'ActiveWorkbook.SaveAs strpath & arrFiles(intcounter)
'ActiveWorkbook.Close
Next intcounter
End Sub
Sub Filtern_Identnummer_Häufigkeit()
'Tabelle nacheinander nach verschiedenen Kriterien filtern und das jeweilige Ergebnis drucken lassen?
Dim arr()
Dim Text_Unterlagenart()
Dim iRow As Integer, icol As Integer
Dim AnzPostotal As Integer
Dim AnzPos As Integer
Dim letzte As Long
Dim Anzahl As Integer
Dim intcounter As Integer
'Anzahl belegter Zeilen in Datei
AnzPostotal = Cells(Rows.Count, 1).End(xlUp).Row
'Ausfiltern Zeilen Spalte A / jede Nummer kommt nur einmal vor
iRow = 1
icol = Cells(iRow, 256).End(xlToLeft).Column + 1
With ActiveSheet.Range("A:A")
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(iRow, icol), _
Unique:=True
End With
AnzPos = Cells(Rows.Count, icol).End(xlUp).Row
MsgBox AnzPos
'Ausfiltern Spalte E nach Kriterien
icol = Cells(2, 256).End(xlToLeft).Column + 1
With ActiveSheet.Range("E:E")
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(1, icol), _
Unique:=True
End With
iRow = 1
Do Until IsEmpty(Cells(iRow, icol))
ReDim Preserve arr(iRow - 1)
iRow = iRow + 1
Loop
'Leerzeile für Autofilter einfügen
If Not IsEmpty(Cells(1, 1)) Then
With Rows("1:1")
.Insert Shift:=xlDown
End With
End If
For iRow = 1 To UBound(arr)
Columns("E").AutoFilter Field:=1, Criteria1:=arr(iRow)
letzte = ActiveSheet.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Anzahl = 0
For intcounter = letzte To 2 Step -1
If Rows(intcounter).RowHeight > 0 Then
Anzahl = Anzahl + 1
End If
Next intcounter
MsgBox Text_Unterlagenart(iRow) & Anzahl
Next iRow
Range("A1").AutoFilter
End Sub