@yummi: Zeilen zusammenfassen
12.03.2018 16:51:09
arek
Hi yummi,
du hast mir im letzten Beitrag folgenden Code als Hilfestellung gegeben, um folgendes zu lösen: "Wenn die Spalten B bis J identisch sind (bis auf den Eintrag in H) sollen diese Zeilen zusammengefasst werden und die eingetragenen Mengen in Spalte H aufaddiert werden ...Hast du dazu eine Idee?"
Bestimme letztte Zeile von B-J
for zeile = erstezeile bis letzte zeile
summe = zeile, B
for spalte = C bis J
if spalte ungleich H then
if zeile, B = Zeile, spalte then
summe = summe + Zeile, spalte
else
summe = 0
spalte = I
end if
end if
next spalte
if summe ungleich 0 then
zeile,H = summe
end if
next zeile
Könntest du das in die angehängte Datei übertragen bzw. einfügen (https://www.herber.de/bbs/user/120368.xlsx) ? Weil ich komme leider nicht ganz klar damit...Das wäre wirklich hilfreich!
Mein derzeitiger Code lautet:
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:\benutzer\arek\Desktop\" '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