kopieren zellinhalte mit zeilenumbruch
09.07.2014 07:32:45
Toni
hier habe ich noch den alten Eintrag hineingestellt und eine geänderte Beispieldatei:
https://www.herber.de/bbs/user/91418.xlsm
Liebe Grüße
Toni
Liebe Excel-Spezialisten,
Ich habe eine Excel-Mappe mit 2 Sheets; einem Quellsheet "Zusammenfassung" und einem Zielsheet "Export".
Im Quellsheet sind in der Spalte A Probennummern (z.B BX0055488, BX00554557, usw.) eingetragen Ein und diesselbe Probennummer kann unterschiedlich oft vorkommen. Dann gibt es in der Spalte C Einträge der Zeichen x oder n.
Das makro soll bei ausführung folgendes tun:
überall wo ein x oder n steht soll der Zellinhalt von A (Zusammenfassung) nach A (Export) kopiert werden; aber nur einmal; dann sollen alle (mit x oder n ) markierten Zellinhalte von D mit integriertem Zeilenumbruch nach b, aber in eine Zelle, kopiert werden.
Klingt kompliziert;is es auch; zum besseren Verständnis hab ich mal eine Arbeitsmappe hochgeladen:
https://www.herber.de/bbs/user/69169.xls
Ich habe bereits sehr viel Zeit (Stunden) das online-Forum durchgestöbert; habe aber nix (nicht mal annähernd) passende makros oder formeln gefunden, mit denen ich das Problem hätte lösen können.
Ich hoffe Ihr könnt mir vielleicht weiterhelfen.
LG
Markus
Hallo,
kannst ja mal testen, müsstest nur noch die Farben anpassen und eventuelle Rahmen einbauen.
Sub Übertragen()
Dim oDic(1)
Dim nCount As Long, MaxRow&
Dim meAr(), meAr_S_M()
For nCount = 0 To 1
Set oDic(nCount) = CreateObject("Scripting.Dictionary")
Next nCount
With Tabelle2
MaxRow = .Cells(.Rows.Count, 3).End(xlUp).Row
meAr = .Range("A3", .Cells(MaxRow, 4)).Value2
meAr_S_M = .Range("M3", .Cells(MaxRow, 13)).Value
End With
For nCount = 1 To Ubound(meAr)
If InStr(";n;x;", LCase(meAr(nCount, 3))) > 0 Then
If oDic(0).exists(meAr(nCount, 1)) Then
oDic(0)(meAr(nCount, 1)) = oDic(0)(meAr(nCount, 1)) & Chr(10) & meAr(nCount, 4)
Else
oDic(0)(meAr(nCount, 1)) = meAr(nCount, 4)
oDic(1)(meAr(nCount, 1)) = meAr_S_M(nCount, 1)
End If
End If
Next nCount
With Tabelle28
MaxRow = .UsedRange(.UsedRange.Rows.Count, 1).Row
If MaxRow > 1 Then
.Range("A2", .Cells(MaxRow, 3)).Clear
If oDic(0).Count > 0 Then
With .Range("A2").Resize(oDic(0).Count)
.Cells.Value = Application.Transpose(oDic(0).keys)
.Cells.Interior.ColorIndex = 4
.Offset(0, 1) = Application.Transpose(oDic(0).items)
.Offset(0, 1).Interior.ColorIndex = 6
.Offset(0, 2) = Application.Transpose(oDic(1).items)
.Offset(0, 2).Interior.ColorIndex = 4
End With
End If
End If
End With
End Sub
Gruß Tino
Hallo,
bin jetzt nicht mehr Online,
hier meine Testdatei zum spielen, hab noch was geändert und hinzugefügt.
https://www.herber.de/bbs/user/69171.xls
Viel Spaß
Gruß Tino
Hallo Tino,
Danke für deine Bemühungen; dein Makro funktioniert echt super; du bist ein wahres Genie !!!
Schönen Abend noch und
LG
Markus