kopieren zellinhalte mit zeilenumbruch

Forumthread: kopieren zellinhalte mit zeilenumbruch

Markus

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: kopieren zellinhalte mit zeilenumbruch

20.04.2010 19:23:35

Tino

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

bin nicht mehr Online, hier Datei ...

20.04.2010 20:29:02

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

AW: bin nicht mehr Online, hier Datei ...

20.04.2010 22:07:24

marky

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

Beliebteste Forumthreads (12 Monate)

kopieren zellinhalte mit zeilenumbruch

Forumthread: kopieren zellinhalte mit zeilenumbruch

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

kopieren zellinhalte mit zeilenumbruch

Forumthread: kopieren zellinhalte mit zeilenumbruch

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread