Thema Datum  Von Nutzer Rating
Antwort
14.02.2022 18:24:01 Mark
NotSolved
14.02.2022 19:40:32 ralf_b
NotSolved
14.02.2022 19:47:46 mark
NotSolved
15.02.2022 07:43:09 ralf_b
NotSolved
15.02.2022 17:19:23 mark
NotSolved
15.02.2022 17:20:52 mark
NotSolved
15.02.2022 19:43:51 ralf_b
NotSolved
15.02.2022 20:25:30 Mark
NotSolved
15.02.2022 21:09:08 ralf_b
NotSolved
16.02.2022 13:49:14 mark
NotSolved
Rot Mail mit Adressen
16.02.2022 21:24:33 ralf_b
Solved
19.02.2022 11:52:52 Mark
NotSolved
16.02.2022 16:24:23 mark
NotSolved

Ansicht des Beitrags:
Von:
ralf_b
Datum:
16.02.2022 21:24:33
Views:
634
Rating: Antwort:
 Nein
Thema:
Mail mit Adressen

fehlen denn Addressen oder sind sie unvollständig?  Ich habe den Code etwas komentiert. Was du nicht benötigst z.b. den letzen Teil mit Spalte B, kannst du ja rausnehmen. Die  Referenzen auf Zellen und Spalten  gelten für das aktive Blatt. Willst du die Namen von einem anderen Blatt holen ,dann muß noch das Tabellenblatt davor.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
'Zellwerte zeilenweise aufteilen
   Do While Cells(i, 1) <> ""
      arr = Split(Cells(i, 1), ";") 'Zellinhalt Spalte A in Array(Datenfeld) schreiben
   'Spalte
      'Zellbereich an Arraygröße anpassen und Array in Tabellenblatt schreiben
      Cells(i, 2).Resize(, UBound(arr) + 1) = arr
     i = i + 1
   Loop
     
   'adressen umschreiben und in dictionary speichern
   'dazu wird der benutzte Datenbereich des Blattes ausgewertet
   For x = 2 To i - 1
     
    'schleife von Spalte 2 bis letzte Spalte des benutzten Bereiches
    For cnt = 2 To UsedRange.SpecialCells(xlCellTypeLastCell).Column
          
         If Cells(x, cnt).Value <> "" Then 'nur gefüllte Zellen bearbeiten
           strAdr = Replace(Trim(Cells(x, cnt).Value), " ", ".") 'Leerzeichen zwischen Namen durch Punkt ersetzen
           strAdr = strAdr & "@xy.com"   'domain an Namen anhängen
           If Not myAddresses.Exists(strAdr) Then
             myAddresses.Add strAdr, 1    'nur nicht vorhandene Adresse in dictionary schreiben
           End If
         End If
    Next cnt
  Next x
 
  'Zellbereich Leer machen
  Range(Cells(2, 2), Cells(x, cnt)).ClearContents
  'eindeutige Adressen ins Tabellenblatt Spalte B schreiben
  Cells(2, 2).Resize(myAddresses.Count).Value = Application.Transpose(myAddresses.Keys)
  Columns(2).AutoFit 'Spaltenbreite anpassen

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
14.02.2022 18:24:01 Mark
NotSolved
14.02.2022 19:40:32 ralf_b
NotSolved
14.02.2022 19:47:46 mark
NotSolved
15.02.2022 07:43:09 ralf_b
NotSolved
15.02.2022 17:19:23 mark
NotSolved
15.02.2022 17:20:52 mark
NotSolved
15.02.2022 19:43:51 ralf_b
NotSolved
15.02.2022 20:25:30 Mark
NotSolved
15.02.2022 21:09:08 ralf_b
NotSolved
16.02.2022 13:49:14 mark
NotSolved
Rot Mail mit Adressen
16.02.2022 21:24:33 ralf_b
Solved
19.02.2022 11:52:52 Mark
NotSolved
16.02.2022 16:24:23 mark
NotSolved