Historie úprav

Avatar uživatele

Odpověděl/a – 21.listopad 0:09

Vyzkoušej tento prográmek. Nevím, jaké máš zkušenosti s VBA. Když tak napiš a já ti poradím, jak postupovat.

Sub EAdresy()
Dim ret$, rad&, radDo&, poz%, pozZ%, pozK%
' Z řetězce v buňkách A vybere emailovou adresu a zkopíruje ji do sloupce B
' POZOR! V textu nesmí být jiný zavináč, než ten v adresách.
For rad = 5000 To 1 Step –1
If Cells(rad, 1).Value <> "" Then radDo = rad: Exit For
Next rad
poz = 1
For rad = 1 To radDo
ret = Cells(rad, 1).Value
Cells(rad, 2).Value = ""
For poz = poz To Len(ret)
If Mid(ret, poz, 1) = „@“ Then
pozZ = poz + 1
pozK = pozZ
While Mid(ret, pozZ, 1) <> " "
pozZ = pozZ – 1
Wend
pozZ = pozZ + 1

N0:
Select Case Mid(ret, pozK, 1)
Case " "
pozK = pozK + 1
If pozK > Len(ret) Then GoTo N1
Case Else
pozK = pozK + 1
If pozK > Len(ret) Then pozK = pozK – 1: GoTo N1
GoTo N0
End Select

N1:
Cells(rad, 2).Value = Cells(rad, 2).Value & Mid(ret, pozZ, pozK – pozZ) & " "
poz = pozK
End If
Next poz
pozZ = 0: pozK = 0: poz = 1
Next rad
End Sub

Podmínkou je, že v textu ve sloupci A budou pouze zavináče (@), které patří adresám.

Avatar uživatele

Odpověděl/a – 21.listopad 0:12

Vyzkoušej tento prográmek. Nevím, jaké máš zkušenosti s VBA. Když tak napiš a já ti poradím, jak postupovat.

Sub EAdresy()
Dim ret$, rad&, radDo&, poz%, pozZ%, pozK%
' Z řetězce v buňkách A vybere emailovou adresu a zkopíruje ji do sloupce B
' POZOR! V textu nesmí být jiný zavináč, než ten v adresách.
For rad = 5000 To 1 Step –1
If Cells(rad, 1).Value <> "" Then radDo = rad: Exit For
Next rad
poz = 1
For rad = 1 To radDo
ret = Cells(rad, 1).Value
Cells(rad, 2).Value = ""
For poz = poz To Len(ret)
If Mid(ret, poz, 1) = „@“ Then
pozZ = poz + 1
pozK = pozZ
While Mid(ret, pozZ, 1) <> " "
pozZ = pozZ – 1
Wend
pozZ = pozZ + 1

N0:
Select Case Mid(ret, pozK, 1)
Case " "
pozK = pozK + 1
If pozK > Len(ret) Then GoTo N1
Case Else
pozK = pozK + 1
If pozK > Len(ret) Then pozK = pozK – 1: GoTo N1
GoTo N0
End Select

N1:
Cells(rad, 2).Value = Cells(rad, 2).Value & Mid(ret, pozZ, pozK – pozZ) & " "
poz = pozK
End If
Next poz
pozZ = 0: pozK = 0: poz = 1
Next rad
End Sub

Podmínkou je, že v textu ve sloupci A budou pouze zavináče (@), které patří adresám.
Doplňuji:
Začátek programu začíná řádkem Sub EAdresy() a končí End Sub