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...
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...