kopieren zellinhalte mit zeilenumbruch

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

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

Beliebteste Forumthreads (12 Monate)

kopieren zellinhalte mit zeilenumbruch

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

330 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

kopieren zellinhalte mit zeilenumbruch

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

330 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread