Aus Liste auswählen und String erstellen

Hallo!
Ich habe eine Liste aus Werten und Zahlen in den Spalten A und E.
In A steht eine Art Artikelbezeichnung und in E eine Zahl.
Nun möchte ich gerne bestimmte Artikel und die zugehörigen Zahlen in
einen einzigen String in Zelle AA4 zusammenfassen.
Dabei muss jedoch ein genaues Format eingehalten werden.
Das Format der Artikelbezeichnung hat die Form ABC DE, wobei die Zeichenkette
vor und nach dem Leerzeichen eine beliebige Anzahl sein kann.
Mir geht es nun darum, alle Artikel die nach dem Leerzeichen nicht GY stehen haben,
in einen String zusammenzufassen.
Dieser soll die Form haben: ABC DE: Zahl aus E; FGH JK: Zahl aus E:
Also immer die Artikelbezeichnung komplett, dann ein ":", die Zahl aus E und dann zwei Leerzeichen.
Damit wird aus der Tabelle:
Spalte A__Spalte E____
ABF DE 1000
FKZ GY 500
ADEF FP 400
ARTD GY 100
der String:
ABF DE: 1000; ADEF FP: 400;
Wie kann ich das per Makro hinkriegen. Habe da leider kaum Ahnung von.
Schonmal vielen Dank für Tipps!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub liste() Dim zeile As Integer, reihe As Integer, zeile1 As Integer, reihe1 As Integer, zeile2 As Integer, _ reihe2 As Integer Application.DisplayAlerts = False Application.ScreenUpdating = False reihe = Range("A65536").End(xlUp).Offset(0, 0).Row Sheets.Add For zeile = 1 To reihe If Right(Cells(zeile, 1), 2) "GY" Then ActiveSheet.Cells(zeile, 1).Value = Sheets("Tabelle1").Cells(zeile, 1).Value & ": " & _ Sheets("Tabelle1").Cells(zeile, 5).Value & "; " End If Next zeile With ActiveSheet reihe1 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row For zeile1 = reihe1 To 1 Step -1 If ActiveSheet.Cells(zeile1, 1).Value = "" Then ActiveSheet.Cells(zeile1, 1).EntireRow.Delete End If Next zeile1 ActiveSheet.Cells(1, 2).Value = ActiveSheet.Cells(1, 1).Value & " " & ActiveSheet.Cells(2, _ 1).Value ActiveSheet.Cells(2, 2).Value = ActiveSheet.Cells(1, 2).Value reihe2 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row For zeile2 = 3 To reihe2 Step 1 ActiveSheet.Cells(zeile2, 2).Value = ActiveSheet.Cells(zeile2 - 1, 2).Value & " " & _ ActiveSheet.Cells(zeile2, 1).Value Next zeile2 Sheets("Tabelle1").Range("AA4").Value = ActiveSheet.Range("B65536").End(xlUp).Offset(0, 0). _ Value ActiveSheet.Delete End With Sheets("Tabelle1").Range("AA4").Select Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Sub liste() Dim zeile As Integer, reihe As Integer, zeile1 As Integer, reihe1 As Integer, zeile2 As _ Integer, _ reihe2 As Integer Application.DisplayAlerts = False Application.ScreenUpdating = False reihe = Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(0, 0).Row Sheets.Add For zeile = 1 To reihe If Right(Sheets("Tabelle1").Cells(zeile, 1), 2) "GY" Then ActiveSheet.Cells(zeile, 1).Value = Sheets("Tabelle1").Cells(zeile, 1).Value & ": " & _ Sheets("Tabelle1").Cells(zeile, 5).Value & "; " End If Next zeile With ActiveSheet reihe1 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row For zeile1 = reihe1 To 1 Step -1 If ActiveSheet.Cells(zeile1, 1).Value = "" Then ActiveSheet.Cells(zeile1, 1).EntireRow.Delete End If Next zeile1 ActiveSheet.Cells(1, 2).Value = ActiveSheet.Cells(1, 1).Value & " " & ActiveSheet.Cells( _ 2, _ 1).Value ActiveSheet.Cells(2, 2).Value = ActiveSheet.Cells(1, 2).Value reihe2 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row For zeile2 = 3 To reihe2 Step 1 ActiveSheet.Cells(zeile2, 2).Value = ActiveSheet.Cells(zeile2 - 1, 2).Value & " " & _ _ ActiveSheet.Cells(zeile2, 1).Value Next zeile2 Sheets("Tabelle1").Range("AA4").Value = ActiveSheet.Range("B65536").End(xlUp).Offset(0, 0) _ . _ Value ActiveSheet.Delete End With Application.DisplayAlerts = True Application.ScreenUpdating = True Sheets("Tabelle1").Range("AA4").Select End Sub

Servus Daniel,
Ich meinet so:


Sub liste()
Dim zeile As Integer, reihe As Integer, zeile1 As Integer, reihe1 As Integer, zeile2 As  _
Integer, _
reihe2 As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
reihe = Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(0, 0).Row
Sheets.Add
For zeile = 2 To reihe
If Right(Sheets("Tabelle1").Cells(zeile, 1), 2)  "GY" And Sheets("Tabelle1").Cells(zeile, _
1).Value  "" Then
ActiveSheet.Cells(zeile, 1).Value = Sheets("Tabelle1").Cells(zeile, 1).Value & ": " & _
Sheets("Tabelle1").Cells(zeile, 5).Value & ";  "
End If
Next zeile
With ActiveSheet
reihe1 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
For zeile1 = reihe1 To 1 Step -1
If ActiveSheet.Cells(zeile1, 1).Value = "" Then
ActiveSheet.Cells(zeile1, 1).EntireRow.Delete
End If
Next zeile1
If ActiveSheet.Range("A1").Value = "" Then
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Tabelle1").Range("AA4").Select
Exit Sub
Else
ActiveSheet.Cells(1, 2).Value = ActiveSheet.Cells(1, 1).Value & "  " & ActiveSheet. _
Cells(2, 1).Value
ActiveSheet.Cells(2, 2).Value = ActiveSheet.Cells(1, 2).Value
reihe2 = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
For zeile2 = 3 To reihe2 Step 1
ActiveSheet.Cells(zeile2, 2).Value = ActiveSheet.Cells(zeile2 - 1, 2).Value & "  " _
& _
ActiveSheet.Cells(zeile2, 1).Value
Next zeile2
Sheets("Tabelle1").Range("AA4").Value = ActiveSheet.Range("B65536").End(xlUp).Offset( _
0, 0).Value
ActiveSheet.Delete
End If
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Tabelle1").Range("AA4").Select
End Sub

Gruß
Chaos

Beliebteste Forumthreads (12 Monate)

Aus Liste auswählen und String erstellen

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Aus Liste auswählen und String erstellen

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread