Excel 2007 - In einem vorhandenen VBA eine Zusätzliche Spalte kopieren

Question

Hallo Zusammen,

ich habe ein gut funktionierendes Makro, das mir Spalten von Tabelle "Übersicht" und "Erledigt" in bestimmter Reihenfolge in die Tabelle "Lagerbewegungen" kopiert.

Nun hätte ich gerne noch eine zusätzliche Spalte (Gebbraucht) ebenfalls mit kopiert. Da ich aber noch nicht der VBA spezialist bin und das vorhandene Makro nicht abschießen will, wäre es super, wenn mir hierbei jemand behilflich sein könnte, und da ich auch noch lernbegierig bin, mir diese noch erklärt.

Die Spalte Gebraucht sollte zischen Wareneingang und Gerätenummer stehen.

Danke schon mal für eure Hilfe.

TESTOBJEKT.xlsm


Gruß
Florian

Answer 1

Testobjekt

Ich glaub, ich werds nie auf anhieb schaffen, einen Link schon beim beschreiben einzustellen.

Answer 2

Hallo zusammen,

hier gleich das Makro auf einen Blick:

Das Array müsste so sein: arr = Array(12, 4, 5, 6, 7, 9, 15, 2)

Sub Makro1()
Dim dteStart As Date, dteEnde As Date, i As Integer, j As Integer, arr, lngRow As Long, lngrow2 As Long
arr = Array(12, 4, 5, 7, 9, 15, 2)
Application.ScreenUpdating = False
With Sheets("Lagerbewegungen")
dteStart = .Cells(4, 3)
dteEnde = .Cells(4, 4)
End With
With Sheets("Übersicht")
.Columns("A:Q").AutoFilter Field:=12, Operator:=xlFilterValues, Criteria1:=">=" & CLng(dteStart), Criteria2:="<=" & CLng(dteEnde)
lngRow = .Cells(.Rows.Count, 12).End(xlUp).Row
lngrow2 = Sheets("Lagerbewegungen").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = LBound(arr) To UBound(arr)
If i = UBound(arr) Then
.Range(.Cells(2, arr(i)), .Cells(lngRow, arr(i))).SpecialCells(xlVisible).Copy
Sheets("Lagerbewegungen").Cells(lngrow2, 13).PasteSpecial Paste:=xlValues
Sheets("Lagerbewegungen").Cells(lngrow2, 13).PasteSpecial Paste:=xlPasteFormats
Else
.Range(.Cells(2, arr(i)), .Cells(lngRow, arr(i))).SpecialCells(xlVisible).Copy
Sheets("Lagerbewegungen").Cells(lngrow2, i + 1).PasteSpecial Paste:=xlValues
Sheets("Lagerbewegungen").Cells(lngrow2, i + 1).PasteSpecial Paste:=xlPasteFormats
End If
Next i

.Columns("A:Q").AutoFilter Field:=12
End With
With Sheets("Erledigt")
For j = 12 To 13
.Columns("A:Q").AutoFilter Field:=j, Operator:=xlFilterValues, Criteria1:=">=" & CLng(dteStart), Criteria2:="<=" & CLng(dteEnde)
lngRow = .Cells(.Rows.Count, j).End(xlUp).Row
If lngRow > 1 Then
lngrow2 = Sheets("Lagerbewegungen").Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(2, j), .Cells(lngRow, j)).SpecialCells(xlVisible).Copy Sheets("Lagerbewegungen").Cells(lngrow2, (j - 12) * 6 + 1)
For i = LBound(arr) + 1 To UBound(arr)
If i = UBound(arr) Then
.Range(.Cells(2, arr(i)), .Cells(lngRow, arr(i))).SpecialCells(xlVisible).Copy
Sheets("Lagerbewegungen").Cells(lngrow2, 13).PasteSpecial Paste:=xlValues
Sheets("Lagerbewegungen").Cells(lngrow2, 13).PasteSpecial Paste:=xlPasteFormats
Else
.Range(.Cells(2, arr(i)), .Cells(lngRow, arr(i))).SpecialCells(xlVisible).Copy
Sheets("Lagerbewegungen").Cells(lngrow2, (j - 12) * 6 + 1 + i).PasteSpecial Paste:=xlValues
Sheets("Lagerbewegungen").Cells(lngrow2, (j - 12) * 6 + 1 + i).PasteSpecial Paste:=xlPasteFormats
End If
Next i
End If
.Columns("A:Q").AutoFilter Field:=j
Next j
End With
With Sheets("Lagerbewegungen")
lngRow = .Cells(.Rows.Count, 7).End(xlUp).Row
.Range(.Cells(7, 14), .Cells(lngRow, 14)).FormulaR1C1 = "=IF(RC[-13]="""",RC[-7],RC[-13])"
.Range(.Cells(7, 1), .Cells(lngRow, 14)).Sort _
Key1:=.Cells(7, 14), Order1:=xlAscending, DataOption1:=xlSortNormal, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Range(.Cells(7, 14), .Cells(lngRow, 14)).ClearContents
.Range(.Cells(6, 1), .Cells(lngRow, 13)).AutoFilter Field:=13, Operator:=xlFilterValues, Criteria1:="Kunde 1"
End With
End Sub


Für mich ein Buch mit 7 Siegeln, für euch doch bestimmt fast lesbar?

Gruß
Florian

Answer 3

Kann mir hier keiner helfen?

VG Florian