identische Zeilen zusammenfassen?
26.01.2018 10:02:11
arek
ich habe folgenden Code, der mir aus einem Ordner, wo verschiedene Listen liegen (alle gleicher Aufbau) Informationen in ein Excel Sheet zieht. Jetzt würde ich gerne den Code erweitern: Es sollen die Zeilen, die komplett identisch sind zu einer Zeile zusammengefasst werden und dabei die Einträge, die in Spalte H stehen, aufaddiert werden. Ist das möglich? Wie Muss ich mein Code umschreiben? Vielen Dank im Voraus!
Option Explicit
Dim wkb As Workbook
Dim wksdata As Worksheet
Dim wksDest As Worksheet
Dim wkbData As Workbook
Sub Update_Button()
Dim llastr As Long
Dim ilasts As Integer
Dim z As Long
Dim s As Integer
Dim llastdest As Long
Dim Pfad As String
Dim Dateiname As String
Dim iRow As Long
Dim arr, na, b As Boolean
Dim FoundCells As Range
Pfad = "C:\Desktop\arek\Hours booking\" 'Pfad, unter welchem die Stundenlisten liegen
Dateiname = Dir(Pfad & "*_hours__booking.xlsm")
Initialisiere 'Funktion Initialisiere siehe unten
On Error Resume Next
wksDest.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeConstants).Value = ""
On Error GoTo 0
Do While Dateiname "" 'Durchlaufen der Stundenlisten
Set wkbData = Workbooks.Open(Filename:=Pfad & Dateiname)
Set wksdata = wkbData.Sheets("Hours")
llastr = BestimmeLetzteZeile(wksdata, 2) 'letzte Zeile erstellen
ilasts = BestimmeLetzteSpalte(wksdata, 2) 'letzte Spalte bestimmen
llastdest = BestimmeLetzteZeile(wksDest, 1) + 1
If ilasts > 54 Then 'Stundenlisten nur bis Spalte 54 durchlaufen
ilasts = 54
End If
If llastr > 1500 Then 'Stundenlisten nur bis Zeile 1500 durchlaufen
llastr = 1500
End If
For z = 5 To llastr 'Alle Zeilen ab Zeile 5 werden durchlaufen
For s = 3 To ilasts 'Alle Spalten ab Spalte C werden durchlaufen
If wksdata.Cells(z, s).Value "" And wksdata.Cells(z, s).Value 0 Then
'Zeile kopieren und anschließender Übergang zur nächsten Stundenliste
wksDest.Cells(llastdest, 1).Value = wksdata.Cells(2, s).Value ' _
Kalenderwoche
wksDest.Cells(llastdest, 4).Value = wksdata.Cells(1, 1).Value ' _
Kostenstelle
wksDest.Cells(llastdest, 5).Value = wksdata.Cells(1, 3).Value ' _
Leistungsart
wksDest.Cells(llastdest, 7).Value = wksdata.Cells(z, 2).Value 'Projektname
wksDest.Cells(llastdest, 8).Value = wksdata.Cells(z, s).Value 'Menge
wksDest.Cells(llastdest, 9).Value = "H" 'ME
wksDest.Cells(llastdest, 10).Value = wksdata.Cells(1, 2).Value ' _
Personalnummer
llastdest = llastdest + 1
End If
Next s
Next z
wkbData.Close False
Set wksdata = Nothing
Set wkbData = Nothing
Dateiname = Dir() 'Automatische Auswahl der nächsten Datei
Loop
End Sub
Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long
BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row
End Function
Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer
If wks.Cells(z, 1).Value "" Then
BestimmeLetzteSpalte = wks.Cells(z, wks.Columns.Count).End(xlToLeft).Column
Else
BestimmeLetzteSpalte = 1
End If
End Function
Function Initialisiere()
If wkb Is Nothing Then
Set wkb = ThisWorkbook
Set wksDest = wkb.Sheets("Overview")
End If
End Function