Hallo,

ich habe in meiner Firma eine Excel-Tabelle bekommen aus der ein Lastenheft für Aufträge erstellt wird. Mit "ctrl+L" wird ein Makro aufgerufen die die vorher in den Tabellen erfassten Daten zu einer Datei zusammenzieht. Dabei werden nur die Zeilen berücksichtigt in der eine gewisse Spalte (in diesem Fall "Menge") gefüllt ist.

Nun zum Problem: beim Ausführen des Makros wird die letzte gefüllte Zeile nicht berücksichtigt. Kann mir da jem. helfen?

hier das Programmierte Makro:

Sub zusammenzugStuecklisten()
'start with CTRL+L
'variables
Dim wbSheet As Worksheet
Dim Departments() As String
Dim ArrayDone As Boolean
Dim found As Boolean
Dim MyForm As New MainForm
Dim actSheet, jobNumber, customer As String

'get all different lines to get cbo box informations
Application.ScreenUpdating = False
ArrayDone = False
found = False
actSheet = ActiveSheet.Name
For Each wbSheet In ActiveWorkbook.Sheets
If wbSheet.Cells(5, 2).Value = "Pos." And Left(wbSheet.Name, 11) <> "Zusammenzug" And wbSheet.Visible Then
wbSheet.Select
[a6].Select
While ActiveCell.Offset(1, 0).Value <> "" Or ActiveCell.Offset(2, 0).Value <> "" Or ActiveCell.Offset(3, 0).Value <> "" Or ActiveCell.Offset(4, 0).Value <> "" Or ActiveCell.Offset(5, 0).Value <> "" Or ActiveCell.Offset(6, 0).Value <> "" Or ActiveCell.Offset(7, 0).Value <> "" Or ActiveCell.Offset(8, 0).Value <> "" Or ActiveCell.Offset(9, 0).Value <> ""
If ActiveCell.Value <> "" Then
If ArrayDone Then
For Each thing In Departments
If ActiveCell.Value = thing Then
found = True
End If
Next thing
If Not found Then
ReDim Preserve Departments(0 To UBound(Departments) + 1) As String
Departments(UBound(Departments)) = ActiveCell.Value
End If
found = False
Else
ReDim Departments(0 To 0) As String
ArrayDone = True
Departments(0) = ActiveCell.Value
End If
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
Next wbSheet
Call BubbleSort(Departments)
For Each thing In Departments
MyForm.cboDepartment.AddItem (thing)
Next thing
MyForm.cboDepartment.AddItem ("Spedition")
MyForm.Show
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' part with copying data ''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If MyForm.cboDepartment.Text <> "" Then
Dim newSheet, acttualSheet, department As String
Dim arrayMade As Boolean
department = MyForm.cboDepartment.Text
jobNumber = Sheets("Deckblatt").Cells(1, 2).Value
customer = Sheets("Deckblatt").Cells(1, 4).Value
For Each wbSheet In ActiveWorkbook.Sheets
If wbSheet.Name = "Zusammenzug " & department Then
MsgBox "Ein Zusammenzug für " & department & " existiert schon, Programm wird beendet."
Exit Sub
End If
Next

Sheets.Add after:=Sheets(Sheets.Count)
newSheet = ActiveSheet.Name
Sheets(newSheet).Name = "Zusammenzug " & department
newSheet = "Zusammenzug " & department

formatNewSheet (newSheet)
[e2].Value = jobNumber
[e2].Font.Bold = True
[e3].Value = customer
[a5].Select
arrayMade = False

For Each wbSheet In ActiveWorkbook.Sheets
If wbSheet.Cells(5, 2).Value = "Pos." And Left(wbSheet.Name, 11) <> "Zusammenzug" And wbSheet.Visible Then
wbSheet.Select
[a6].Select
While ActiveCell.Offset(1, 0).Value <> "" Or ActiveCell.Offset(2, 0).Value <> "" Or ActiveCell.Offset(3, 0).Value <> "" Or ActiveCell.Offset(4, 0).Value <> "" Or ActiveCell.Offset(5, 0).Value <> "" Or ActiveCell.Offset(6, 0).Value <> "" Or ActiveCell.Offset(7, 0).Value <> "" Or ActiveCell.Offset(8, 0).Value <> "" Or ActiveCell.Offset(9, 0).Value <> ""
If department <> "Spedition" Then
If department = ActiveCell.Value Or (department = "L2" And ActiveCell.Value = "") Then
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value > 0 And ActiveCell.Offset(0, 6).Value <> " " Then
copyData wbSheet.Name, newSheet
End If
End If
Else
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value > 0 And ActiveCell.Offset(0, 6).Value <> " " Then
copyData wbSheet.Name, newSheet
End If
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
Next
Sheets(newSheet).Select
[a5].Select
While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Wend
rowNumber = ActiveCell.Offset(-1, 0).Row
formatNormalLine "A5", "J" & rowNumber
formatNormalLine "L5", "L" & rowNumber
[a5].Select 'bmnmbnmbn
Columns.AutoFit
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$J$" & rowNumber
.FitToPagesWide = 1
.Orientation = xlLandscape
End With
Else
Sheets(actSheet).Select
End If
Application.ScreenUpdating = True
End Sub

Sub BubbleSort(MyArray() As String)

Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
Dim List As String

First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
Temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = Temp
End If
Next j
Next i

For i = 1 To UBound(MyArray)
List = List & vbCrLf & MyArray(i)
Next
'MsgBox List

End Sub

Private Sub copyData(ByVal actualName As String, ByVal summaryName As String)
Dim dataArray(9) As String
dataArray(0) = ActiveCell.Value
dataArray(1) = ActiveCell.Offset(0, 1).Text
dataArray(2) = ActiveCell.Offset(0, 2).Value
dataArray(3) = ActiveCell.Offset(0, 3).Value
dataArray(4) = ActiveCell.Offset(0, 4).Value
dataArray(5) = ActiveCell.Offset(0, 6).Value
dataArray(6) = ActiveCell.Offset(0, 8).Value
dataArray(7) = ActiveCell.Offset(0, 9).Value
dataArray(8) = ActiveCell.Offset(0, 11).Value & " " & ActiveCell.Offset(0, 12).Value
dataArray(9) = ActiveCell.Offset(0, 24).Value
Sheets(summaryName).Select
If dataArray(0) = "" Then dataArray(0) = "N/A"
ActiveCell.Value = dataArray(0)
ActiveCell.Offset(0, 1).Value = dataArray(1)
ActiveCell.Offset(0, 2).Value = dataArray(2)
ActiveCell.Offset(0, 3).Value = dataArray(3)
ActiveCell.Offset(0, 4).Value = dataArray(4)
ActiveCell.Offset(0, 5).Value = dataArray(5)
ActiveCell.Offset(0, 6).Value = dataArray(6)
ActiveCell.Offset(0, 7).Value = dataArray(7)
ActiveCell.Offset(0, 9).Value = dataArray(8)
ActiveCell.Offset(0, 11).Value = dataArray(9)
ActiveCell.Offset(1, 0).Select
Sheets(actualName).Select
End Sub

Private Sub formatNewSheet(ByVal sheetName As String)
[d2].Value = sheetName
[d2].Font.Size = 18
[d2].Font.Bold = True
[j3].Value = Date
[b4].Value = "Pos."
[c4].Value = "Kiste"
[d3].Value = "Kunde:"
[d4].Value = "Gegenstand"
[e4].Value = "Typ"
[f4].Value = "Menge"
[g4].Value = "Art.-Nr."
[h4].Value = "Zeichn.-Nr."
[j4].Value = "Bemerkungen"
[l4].Value = "Label"
doNormalLinesAround "A1", "C3"
doNormalLinesAround "D1", "J3"
doNormalLinesAround "L1", "L3"
doNormalLinesAround "L4", "L4"
formatFirstLine "A4", "J4"
ActiveWindow.DisplayGridlines = False
End Sub

Private Sub doNormalLinesAround(ByVal firstCell As String, ByVal lastCell As String)
Range(firstCell & ":" & lastCell).Select
With selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
End Sub

Private Sub formatFirstLine(ByVal firstCell As String, ByVal lastCell As String)
Range(firstCell & ":" & lastCell).Select
With selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub

Private Sub formatNormalLine(ByVal firstCell As String, ByVal lastCell As String)
Range(firstCell & ":" & lastCell).Select
With selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End Sub

Vielen Dank für eure hilfe...

Wenn Du uns sagst welche von den WHILE Schleifen Du meinst könnte man Dir evtl. helfen.

Aber versuchs doch mal mit einem kleinen Beispiel und gehe komplett schriftweise (F8) durch den Code. Dabei müsste Dir der Fehler eigentlcih auffallen.

gemeint ist diese Schleife:

While ActiveCell.Offset(1, 0).Value <> "" Or ActiveCell.Offset(2, 0).Value <> "" Or ActiveCell.Offset(3, 0).Value <> "" Or ActiveCell.Offset(4, 0).Value <> "" Or ActiveCell.Offset(5, 0).Value <> "" Or ActiveCell.Offset(6, 0).Value <> "" Or ActiveCell.Offset(7, 0).Value <> "" Or ActiveCell.Offset(8, 0).Value <> "" Or ActiveCell.Offset(9, 0).Value <> ""
If ActiveCell.Value <> "" Then
If ArrayDone Then
For Each thing In Departments
If ActiveCell.Value = thing Then
found = True
End If
Next thing
If Not found Then
ReDim Preserve Departments(0 To UBound(Departments) + 1) As String
Departments(UBound(Departments)) = ActiveCell.Value
End If
found = False
Else
ReDim Departments(0 To 0) As String
ArrayDone = True
Departments(0) = ActiveCell.Value
End If
End If
ActiveCell.Offset(1, 0).Select
Wend

Das schrittweise durchgehen hat bis jetzt nichts gebracht... konnte nicht entdecken was der Fehler sein könnte...

conhold schrieb:

While ActiveCell.Offset(1, 0).Value <> "" Or ActiveCell.Offset(2, 0).Value <> "" Or ActiveCell.Offset(3, 0).Value <> "" Or ActiveCell.Offset(4, 0).Value <> "" Or ActiveCell.Offset(5, 0).Value <> "" Or ActiveCell.Offset(6, 0).Value <> "" Or ActiveCell.Offset(7, 0).Value <> "" Or ActiveCell.Offset(8, 0).Value <> "" Or ActiveCell.Offset(9, 0).Value <> ""

Hier liegt der Fehler.
Was möchtest Du denn hier machen? Du prüfst vor dem Durchlauf durch die Schleife, ob in der nächsten Zeile noch was drinsteht. Wenn Du in der letzten Zeile stehst, wird diese logischerweise nicht mehr geprüft.
Lösung 1: Bedingungen ändern
Lösung 2: Fußgesteuerte Schleife anstatt der kopfgesteuerten.

Ok. Danke das hilft mir schon mal weiter...

am liebsten würde ich mich für Lösung 1 entscheiden.

könntest du mir die neue bedingung mitteilen? wäre echt nett. hab schon einiges versucht aber nichts hat hingehauen...

Danke schonmal!!!

Warum prüfst Du überhaupt, dass ob die nächsten 9 Zeilen gefüllt sind? Normalerweise prüft man bei der kopfgesteuerten Routine, so wie Du Deinen Code geschrieben hast, nur die aktuelle Zeile.

Tja... wie gesagt. ich habe das File nur so bekommen und soll ein paar Änderungen vornehmen. Eigentlich mach ich sowas sonst nie. Jetzt hab ich halt versucht, mich da reinzuarbeiten aber so ganz bin ich aus der Sache nicht rausgekommen. Deswegen würde ich es gerne so lassen und nur die kleineren Änderungen vornehmen.

Da fällt mir auch gleich das nächste Problem ein. und zwar werden bei diesem Zusammenzug negative Werte nicht berücksichtigt. Fällt dir was dazu ein?

Was verstehst Du unter neagtiven Werte?

-12 zum Beispiel

Wo interessieren dich denn die Werte? Bzw. in welchem Code teil können siese denn vorkommen? Ich sehe da nichts kritisches.

Also die Werte werden in einer anderen Tabelle in eine Spalte "Menge" eingetragen. Hin und wieder kommt es vor das gewisse Bauteile wieder demontiert werden und das wird in der Spalte Menge mit z.B. -5 eingetragen. Bei ausführen des Makros werden aber nur positive Werte berücksichtigt. Wo genau das festgelgt ist hab ich auch noch nicht entdecken können.

keiner ne Idee????

Hallo conhold,

Den Sinn der Abfrage ob irgendeine Spalte 1 der folgenden 9 Zeilen nicht leer ist verstehe ich auch nicht.
Es könnte höchstens sein das eventuelle Leerzeilen (max. 9) nicht zum Abbruch führen sollen.

Versuch mal die Abfrage auf die aktuelle Zeile zu erweitern:

While ActiveCell.Offset(0, 0).Value <> ""Or ActiveCell.Offset(1, 0).Value <> "" Or ActiveCell.Offset(2, 0).Value <> "" ... usw

Hallo Eierlein,

das war die Lösung. Vielen Dank!!!

Könntest du mir vielleicht noch bei dem Problem mit den negativen Werten helfen?

Hallo conhold,

Das einzige was ich bezüglich der negativen Werte gefunden habe ist im folgenden Code-Ausschnitt fett hervorgehoben.
Ist die Spalte Menge die 6. Spalte?


...
If department = ActiveCell.Value Or (department = "L2" And ActiveCell.Value = "") Then
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value > 0 And ActiveCell.Offset(0, 6).Value <> " " Then
copyData wbSheet.Name, newSheet
End If
End If
Else
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value > 0 And ActiveCell.Offset(0, 6).Value <> " " Then
...


Du kannst mal testweise die Zeilen:
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value > 0 And ActiveCell.Offset(0, 6).Value <> " " Then
in
If ActiveCell.Offset(0, 6).Value <> "" And ActiveCell.Offset(0, 6).Value <> " " Then
ändern.

Wenn das dann mit den negativen Werten funktioniert, muss man sich eine andere Abfrage nach Zahlenwerten einfallen lassen.
Evtl. kann man auch Value > -13 eintragen, wenn der größte negative Wert -12 ist.

Hallo eierlein.

Du hattest wieder recht. Spalte 6 war die Zeile für Menge. Vielen Dank für den Hinweis.

Ich habe das Problem mit einer anderen Bedingung lösen können. Ich muss dazu auch keinen negativen Werte vorgeben.

And ActiveCell.Offset(0, 6).Value <> 0

... ist die magische Bedingung. Somit ist es auch egal wie gross der negative Wert ist. ein Max-Wert hätte es nicht gegeben.

somit sind alle Probleme behoben. Nochmal vielen Dank für die Hilfe.

Gruss conhold