Datei ergänzen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub EingabenUebernehmen() ' Der Code steht in Mappe 77259.xlsm Dim lngE As Long, arE, ee As Long Dim lngS As Long, arN, arD, vv, ss As Long, cc As Long ThisWorkbook.Activate With Workbooks("77260.xls").Sheets(1) ' anpassen lngE = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 arE = .Cells(2, 1).Resize(lngE, 6) End With With Sheets("EAN PRD AEKLAR") lngS = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 arN = Application.Transpose(.Cells(2, 1).Resize(lngS)) arD = .Cells(2, 8).Resize(lngS, 3) For ee = 1 To lngE vv = Application.Match(arE(ee, 1), arN, 0) If IsNumeric(vv) Then ss = vv + 1 Else lngS = lngS + 1 ss = lngS + 1 .Cells(ss, 1) = arE(ee, 1) End If For cc = 2 To 4 If arE(ee, cc) > "" Then If IsEmpty(.Cells(ss, cc + 6)) Then _ .Cells(ss, cc + 6) = arE(ee, cc) End If Next cc For cc = 5 To 6 If arE(ee, cc) > "" Then .Cells(ss, cc + 6) = arE(ee, cc) Next cc Next ee End With End Sub

Hi Markus,
ich hatte geschrieben:


Du müsstest nun genauer beschreiben, was wann woher wohin übertragen werden soll.

Meinst du wirklich, dass das mit einem "manchmal so, manchmal auch so" erledigt ist?
Da erwarte ich von dir etwas mehr...
Nebenbei: "manchmal so, manchmal auch so" könnte man etwa mittels Zufallsfunktion programmieren...
Wieder mal meine Vermutung:
Jeder der maximal drei Eingabewerte (aus den Spalten B:D) wird in die erste freie Zelle
in den Spalten H:J des Zielblatts geschrieben - sofern nicht schon alle drei Zielzellen gefüllt sind.
Frage 1:
Trifft meine Vermutung zu?
Frage 2:
Was soll mit Eingaben passieren, für die in der Zielzeile kein Platz mehr ist?
Frage 3:
Was soll passieren, wenn ein Eingabewert bereits in einer der möglichen Zielzellen auftaucht?
Frage 4: (aus meinem 2. Beitrag)
Hattest du im Modul die Zeile "Option Explicit" (als erste Zeile) weggelassen? (Ich will hoffen, sie steht (wieder) drin...)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hi Markus,
es scheint recht schwer zu sein, so eine Aufgabe zu definieren...
Die farblichen Markierungen (für "bereits vorhanden" bzw. "wg. Platzmangels nicht übertragen"
werden im Eingabeblatt vorgenommen. Probier mal


Option Explicit     ' immer zu empfehlen !!
Sub EingabenUebernehmen()        ' Der Code steht in Mappe 77259.xlsm
Dim lngE As Long, arE, ee As Long
Dim lngS As Long, arN, arD, vv, ss As Long, cc As Long, ff As Long
ThisWorkbook.Activate
Sheets("EAN PRD AEKLAR").Activate
With Workbooks("77260.xls").Sheets("Eingabe")      ' anpassen
lngE = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
arE = .Cells(2, 1).Resize(lngE, 6)
lngS = Cells(Rows.Count, 1).End(xlUp).Row - 1
arN = Application.Transpose(Cells(2, 1).Resize(lngS))
arD = Cells(2, 8).Resize(lngS, 3)
For ee = 1 To lngE
vv = Application.Match(arE(ee, 1), arN, 0)
If IsNumeric(vv) Then
ss = vv + 1
Else
lngS = lngS + 1
ss = lngS + 1
Cells(ss, 1) = arE(ee, 1)
End If
For cc = 2 To 4
If arE(ee, cc) > "" Then
For ff = 8 To 10
If Cells(ss, ff) = arE(ee, cc) Then
.Cells(ee + 1, cc).Interior.Color = 65535
Exit For
ElseIf Cells(ss, ff) = "" Then
Cells(ss, ff) = arE(ee, cc)
Exit For
End If
Next ff
If ff > 10 Then .Cells(ee + 1, cc).Interior.Color = 49407
End If
Next cc
For cc = 5 To 6
If arE(ee, cc) > "" Then Cells(ss, cc + 6) = arE(ee, cc)
Next cc
Next ee
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread