Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dringend: Anpassung/Änderung eines VBA codes

Dringend: Anpassung/Änderung eines VBA codes
Manu
Hallo liebe Excel Freunde,
dringend Hilfe gesucht!!!
Nachdem mir bereits durch eure Hilfe ein VBA Code für mein Problem erstellt wurde, suche ich nun Hilfe um den Code noch ein Stück weit anzupassen.
https://www.herber.de/bbs/user/75729.zip
Und zwar besteht die angefügte Datei aus drei Tabellenblättern. Die Tabelle R holt sich die Daten aus Tabelle P und M. Da die Zeile test1 und test2 in Tabelle P nur einmal vorkommt werden diese daten auch nur einmal in Tabelle R übertragen. In Tabelle M sind unter test1 und test2 aber jeweils 2 Zeilen eingetragen. Demzufolge werden diese Zeilen auch in der Anzahl in Tabelle R wiedergegeben. Es wird immer der Fall sein, dass die unter Spalte A aus Tabelle P eingetragenen Nr. immer nur einmal vorkommt.
Was ich gern möchte ist folgendes:
Jedesmal wenn in Tablle M eine nr. in Spalte A mehrmals vorkommt und nach Tabelle R übertragen wird, soll in Tabelle R die gleiche Anzahl an Zeilen generiert werden um die Daten, welche unter dieser nr. in Tabelle P eingetragen sind zu übertragen. Dies bedeutet, dass der unter dieser No. stehenden Eintrag aus Tabelle P zwar derselbe ist, aber genau so häufig angezeigt werden soll, wie es Daten mit dieser no. aus Tabelle M gibt.
In der Anlage in Tabelle R sind die Zeilen gelb markiert in welche die Daten aus tabelle P mit der gleichen nr. nochmals generiert werden sollen.
Ich bitte um eure Hilfe, da ich keine Anpassungsmöglichkeit des vorhandenen Codes für dieses Problem weiß.
Gruß und vielen Dank im Voraus
Manu
Wer kann helfen?
Manu
Wer hat mir eine Lösung?
Gruß
Manu
AW: Dringend: Anpassung/Änderung eines VBA codes
René
Hallo Manu,
ich versteh das problem nicht ganz. Sende bitte mal eine Tabelle wie das Ergebnsi genau aussehen soll. Momentan kann ich mir das nicht ganz zusammenreinem. Aber vielleicht kann man Dir ja helfen. Lade mal eine Tabelle hoch wie das Endergebnis aussehen soll.
Danke René
Tabelle mit Ergebnis hochgeladen!
Manu
Hallo René,
vielen Dank für dein Feedback.
https://www.herber.de/bbs/user/75746.zip
Ich habe jetzt mal die ganze Datei nochmals hochgeladen. So wie ich es in Tabelle r nun manuell noch nachgetragen habe, soll es aussehen. Die daten aus tabelle P der jeweiligen M. Nr. sollen in tabelle R so häufig erscheinen wie es auch Daten aus tabelle M mit der jeweiligen M. Nr. gibt. und dafür habe ich nun die jeweilige stelle in Tabelle R markiert und die daten manuell eingetragen.
Wenn du die daten dann aus der tabelle r löschst und auf Makro ausführen klickst, kommt eben der VBA code wie er derzeit gespeichert ist.
Vielen Dank und Gruß
Manu
Anzeige
AW: Tabelle mit Ergebnis hochgeladen!
René
Hallo Manu,
habe heute keine Zeit mehr gefunden - mekde mich morgen Mittag
Gruß René
Rückmeldung
Manu
Hey René,
vielen Dank.
Bis dahin, viele Grüße
Manu
AW: Rückmeldung
René
Hallo Manu,
wenn es mehr Zeilen werden können entweder weiter anpassen oder mich noch mal anschreiben.
Anbei ein Ansatz
Sub tabellen_zusammenfassen()
Dim refNr As Range, sNr As Range
Dim lZeile1 As Long, lZeile2 As Long, lZeile3 As Long
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Set wks1 = Worksheets("Tabelle R")
Set wks2 = Worksheets("Tabelle P")
Set wks3 = Worksheets("Tabelle M")
lZeile1 = wks1.Cells(Rows.Count, 1).End(xlUp).Row
lZeile2 = wks2.Cells(Rows.Count, 1).End(xlUp).Row
lZeile3 = wks3.Cells(Rows.Count, 1).End(xlUp).Row
If Not lZeile1 = 1 Then wks1.Range(wks1.Cells(2, 1), wks1.Cells(lZeile1, 18)).ClearContents
lZeile1 = 2
For Each refNr In wks2.Range(wks2.Cells(2, 1), wks2.Cells(lZeile2, 1))
If refNr  "" Then
wks1.Cells(lZeile1, 1) = refNr.Value
wks1.Cells(lZeile1, 2) = refNr.Offset(0, 1)
wks1.Cells(lZeile1, 3) = refNr.Offset(0, 2)
wks1.Cells(lZeile1, 4) = refNr.Offset(0, 3)
wks1.Cells(lZeile1, 5) = refNr.Offset(0, 4)
wks1.Cells(lZeile1, 6) = refNr.Offset(0, 5)
wks1.Cells(lZeile1, 7) = refNr.Offset(0, 6)
wks1.Cells(lZeile1, 8) = refNr.Offset(0, 7)
wks1.Cells(lZeile1, 9) = refNr.Offset(0, 8)
wks1.Cells(lZeile1, 10) = refNr.Offset(0, 9)
For Each sNr In wks3.Range(wks3.Cells(2, 1), wks3.Cells(lZeile3, 1))
If refNr = sNr Then
wks1.Cells(lZeile1, 1) = sNr.Value
wks1.Cells(lZeile1, 11) = sNr.Offset(0, 1)
wks1.Cells(lZeile1, 12) = sNr.Offset(0, 2)
wks1.Cells(lZeile1, 13) = sNr.Offset(0, 3)
wks1.Cells(lZeile1, 14) = sNr.Offset(0, 4)
wks1.Cells(lZeile1, 15) = sNr.Offset(0, 5)
wks1.Cells(lZeile1, 16) = sNr.Offset(0, 6)
wks1.Cells(lZeile1, 17) = sNr.Offset(0, 7)
wks1.Cells(lZeile1, 18) = sNr.Offset(0, 8)
lZeile1 = lZeile1 + 1
End If
Next
lZeile1 = lZeile1 + 1
End If
Next
If wks1.Cells(3, 1).Value = "test1" Then
Range("B2:I2").Select
Selection.Copy
Range("B3").Select
ActiveSheet.Paste
End If
If wks1.Cells(4, 1).Value = "test1" Then
Range("B3:I3").Select
Selection.Copy
Range("B4").Select
ActiveSheet.Paste
End If
If wks1.Cells(6, 1).Value = "test2" Then
Range("B5:I5").Select
Selection.Copy
Range("B6").Select
ActiveSheet.Paste
End If
If wks1.Cells(7, 1).Value = "test2" Then
Range("B6:I6").Select
Selection.Copy
Range("B7").Select
ActiveSheet.Paste
End If
Set wks1 = Nothing
Set wks2 = Nothing
Set wks3 = Nothing
End Sub
Gruß René
Anzeige
AW: Rückmeldung
Manu
Hallo Rene,
zunächst mal vielen Dank für deine Unterstützung.
Nach deinem code muss ja nun genau der jeweilige Wert z.B. "test1" vorkommen, damit die Daten in die darunterliegende Zeile kopiert bzw. erzeugt werden. Gibt es da noch eine andere Möglichkeit, da die Tabelle auf eine riesen Menge von Daten ausgerichtet werden soll, ist es unmöglich manuell für jeden einzelnen Wert in spalte M.Nr. den Code anzupassen?
Viele Grüße
Manu
AW: Rückmeldung
René
Oki. War ja auch nur ein Ansatz. Wusste nicht das die Werte mehrmals vorkommen. Mustafa hat Dir glaube ich eine Lösung vorgestellt
AW: Rückmeldung
Manu
Die Lösung von Mustafa habe ich auf meine Bedürfnisse angepasst. Dabei wurde diese Problematik aber noch nicht mit berücksichtigt. Deshalb hatte ich mich nochmals an euch gewendet. Der VBA code wie er in der Test datei vorliegt ist der derzeitige code.
Hast du noch einen anderen Ansatz?
Gruß und Danke
Anzeige
Hat noch jemand Rat?
Manu
Weiß noch wer eine Lösung?
VBA: Kann mir niemand weiterhelfen?
Manu
Suche immer noch dringend Hilfe für mein oben beschriebenes Problem?
Gruß
Manu aus Müchen
AW: VBA: Kann mir niemand weiterhelfen?
Manu
Suche immer noch dringend Hilfe für mein oben beschriebenes Problem?
Gruß
Manu aus München
AW: Dringend: Anpassung/Änderung eines VBA codes
Gerold
Hallo Manu
Probiers mal so

Option Explicit
Sub tabellen_zusammenfassen()
Dim refNr As Range, sNr As Range, i As Integer, j As Integer
Dim lZeile1 As Long, lZeile2 As Long, lZeile3 As Long
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Set wks1 = Worksheets("Tabelle R")
Set wks2 = Worksheets("Tabelle P")
Set wks3 = Worksheets("Tabelle M")
lZeile1 = wks1.Cells(Rows.Count, 1).End(xlUp).Row
lZeile2 = wks2.Cells(Rows.Count, 1).End(xlUp).Row
lZeile3 = wks3.Cells(Rows.Count, 1).End(xlUp).Row
If Not lZeile1 = 1 Then wks1.Range(wks1.Cells(2, 1), wks1.Cells(lZeile1, 18)).ClearContents
lZeile1 = 2
For Each refNr In wks2.Range(wks2.Cells(2, 1), wks2.Cells(lZeile2, 1))
If refNr  "" Then
wks1.Cells(lZeile1, 1) = refNr.Value
For i = 1 To 9
wks1.Cells(lZeile1, i + 1) = refNr.Offset(0, i)
Next i
j = 0
For Each sNr In wks3.Range(wks3.Cells(2, 1), wks3.Cells(lZeile3, 1))
If refNr = sNr Then
j = j + 1
wks1.Cells(lZeile1, 1) = sNr.Value
For i = 1 To 8
wks1.Cells(lZeile1, i + 10) = sNr.Offset(0, 1)
Next i
If j > 1 Then
wks1.Cells(lZeile1, 1) = refNr.Value
For i = 1 To 9
wks1.Cells(lZeile1, i + 1) = refNr.Offset(0, i)
Next i
End If
lZeile1 = lZeile1 + 1
End If
Next
lZeile1 = lZeile1 + 1
End If
Next
Set wks1 = Nothing
Set wks2 = Nothing
Set wks3 = Nothing
End Sub
Mfg Gerold
Rückmeldung wäre nett.
Anzeige

315 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige