Schleife Liste abarbeiten

Hallo!
Ich habe in Excel eine Arbeitsblatt EINGABE und ein Arbeitsblatt DATEN.
In EINGABE habe ich übersichtlich alle Eingabefelder angeordnet und die Zellen auch benannt (z.B "Firma", "Straße", "PLZ", ...)
In DATEN habe ich eine Tabelle mit den dazupassenden Tabellenüberschriften (z.B "Firma", "Straße", "PLZ", ...).
Per Klick soll eine VBA Routine alle Einträge vom EINGABE Arbeitsblatt in das DATEN Arbeitsblatt in die obester Reihe nach der Überschrift - als in Reihe 2 - eintragen und die Eingebefelder im Arbeitsblatt EINGABE für die nächte Eingebe wieder löschen.
Per MacroAufzeichnung habe ich das Grundsätzlich schon gelöst - das Problem ist einerseits die Übersichtlichkeit des Ergebnisses und die Wartung ... wenn z.B. ein Datenfeld dazu kommt.
Range("Firma").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("DATEN").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("EINGABE").Select
Ziel ist es also, das Ganze übersichtlicher zu gestalten. Dazu dachte ich zum Einen an eine Funktion, welche das Kopieren von A nach B übernimmt wie:
Function ZelleKopieren(strZelleA, strZelleB)
Zum Anderen dachte ich an eine Liste mit Ausgangsort und Zielort, welche in einer Schleife abgearbeitet wird:
z.B ("Firma"; F2; "Straße"; G2; "PLZ"; H2; ....)
(Dass in im Datenarbeitsblatt auch mit Zellennamen arbeite ist wohl nicht möglich, da ich die Zeile vor der ganzen Routine erst erst einfüge. Dass ich "intelligent" die Überschrift der Spalte heranziehe (wo ja "Firma" steht), halte ich dann für wahrscheinlich überhaupt kompliziert. Mir wäre aber mit der Listenversion schon sehr, sehr geholfen.)
Mir bin für jeden Tipp dankbar. Ich stehe ich einfach an.
Vielen Dank und liebe Grüße,
Wolfgang

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Wolfgang() Dim avntValues As Variant, vntItem As Variant Dim objDictionary As Object, objWorksheet As Worksheet With Worksheets("Tabelle1") 'Tabellenname anpassen !!! If .FilterMode Then Call .ShowAllData avntValues = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).Value2 Set objDictionary = CreateObject(Class:="Scripting.Dictionary") For Each vntItem In avntValues objDictionary.Item(Key:=vntItem) = vbNullString Next avntValues = objDictionary.Keys Set objDictionary = Nothing For Each vntItem In avntValues Set objWorksheet = Worksheets.Add(After:=Worksheets(Worksheets.Count)) objWorksheet.Name = vntItem Call .Rows(1).AutoFilter(Field:=6, Criteria1:=vntItem) Call .AutoFilter.Range.Copy(Destination:=objWorksheet.Cells(1, 1)) Next Set objWorksheet = Nothing Call .ShowAllData End With End Sub

Option Explicit Public Sub Übertragen() Dim loLetzte As Long, i As Long, z As Long Dim varArray() As Variant Application.ScreenUpdating = False With Worksheets("Eingabe") loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row ReDim varArray(loLetzte) For i = 2 To loLetzte If .Cells(i, "B") "" Then varArray(z) = .Cells(i, "C") z = z + 1 End If Next i .Range(.Cells(2, "C"), .Cells(loLetzte, "C")).ClearContents End With With Worksheets("Daten") .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _ .Resize(, loLetzte) = varArray End With End Sub

Hallo Wolfgang,
so, ich habe jetzt noch ein paar kleine Änderungen am Code vorgenommen, z.B. die Größe des Array exakt festgelegt, und mit Kommentaren versehen.

Option Explicit
Public Sub Übertragen()
Dim loLetzte As Long, i As Long, z As Long
Dim varArray() As Variant, loLeer As Long
Application.ScreenUpdating = False
With Worksheets("Eingabe")
'letzte belegte Zelle in Spalte B ermitteln
loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row
'Anzahl Leerzellen im Bereich B1 bis B letzte belete Zelle ermitteln
loLeer = WorksheetFunction.CountBlank(.Range(.Cells(1, "B"), .Cells(loLetzte, "B")))
'Schleifenzähler für Array auf 1 setzen
z = 1
'Anzahl der Einträge ins Array festlegen
ReDim varArray(1 To loLetzte - loLeer)
'Schleife über die Eingabefelder
For i = 2 To loLetzte
'Wenn Eintrag in Zelle in B
If .Cells(i, "B")  "" Then
'den Eintrag aus C ins Array schreiben
varArray(z) = .Cells(i, "C")
'Zähler für Arrayeintrag hochsetzen
z = z + 1
End If
'nächste Zelle in B
Next i
'Eingabefelder leeren
.Range(.Cells(2, "C"), .Cells(loLetzte, "C")).ClearContents
End With
With Worksheets("Daten")
'Array in die Tabelle schreiben, unter letztem Eintrag
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _
.Resize(, loLetzte - loLeer) = varArray
End With
End Sub

Du hälst wohl deinen aufgezeichneten Code für verständlicher / übersichtlicher?
Wenn du von VBA wenig bis gar keine Ahnung hast, dann solltest du in einem Forum wohl besser nicht nachfragen.
Da wird es dir nämlich immer wieder passieren, dass du Codebeispiele bekommtst, die du nicht verstehst.
Und zur Anmerkung: traue ich mich nicht ihn bei mir anzuwenden...
Wo ist das Problem, von deiner Datei eine Sicherungskopie anzulegen und dann damit den Code zu testen?
Was du im Übrigen immer machen solltest bei solchen Sachen.
Mach jetzt damit was du willst.
Gruß Werner

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread