Saisinko joltain helppiä kyseisen makron sieventämiseen noiden Array:den osalta.
Makron tarkoitus on purkaa puolipisteellä erotettuja sähköpostiosoitteita, jotka on kopioitu Outlookista. Niitä on esimerkissä kolmisen kymmentä, mutta joskus lähes sata.
Sub Sposti()
' Sposti Makro
'
' Pikanäppäin: Ctrl q
'
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
33, 1)), TrailingMinusNumbers:=True
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A4"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="<", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Range("B4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:=">", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("B:B").ColumnWidth = 26.29
Columns("A:A").ColumnWidth = 29.43
Range("A4").Select
End Sub
Makron sieventämistä
7
303
Vastaukset
- Kundepuu
Sub PutsaaEmailit()
Dim Email As Variant
Dim Putsattu As String
'jos tarttee korvata muita merkkejä lisää alle
Putsattu = Replace(Range("A1"), "<", "")
Putsattu = Replace(Putsattu, ">", "")
Email = Split(Range("A1"), ";")
'muuta kopioalueen eka solu sopivaksi
Range("A4").Resize(UBound(Email) 1).Value = Application.WorksheetFunction.Transpose(Email)
End Sub
Keep EXCELing
@Kunde - Mailit_ojoon
Kiitos Kunde. Olipas tuo sievistynyt kovasti. Mutta jotain eroa täytyy olla Kunden ja mun versioissa, sillä mun tapauksessa toimii ainoastaan splittaus puolipisteen perusteella sekä Transpose. Sähköpostiosoitteen alussa ja lopussa olevat < ja > jäivät paikalleen, eikä offset ( 1) myöskään toiminut.
Alkuasetelma on siis sellainen, että solussa A1 on kopioidut sähköpostiosoitteet muodossa Nimi <[email protected]>; Nimi<[email protected]>; Nimi<[email protected]> jne...
Nimi ja sähköpostiosoite pitäisi saada eri sarakkeisiin muotoon
Nimi [email protected]
Nimi [email protected]
Nimi [email protected]
jne... - Kundepuu
painovirhepaholainen ja erilainen lähtötieto...
Sub PutsaaEmailit()
Dim Email As Variant
Dim Putsattu As String
'jos tarttee korvata muita merkkejä lisää alle
Putsattu = Replace(Range("A1"), "<", "|")
Debug.Print Putsattu
Putsattu = Replace(Putsattu, ">", "")
Debug.Print Putsattu
Email = Split(Putsattu, ";")
'muuta kopioalueen eka solu sopivaksi
Range("A4").Resize(UBound(Email) 1).Value = Application.WorksheetFunction.Transpose(Email)
Range("A4").Resize(UBound(Email) 1).TextToColumns Destination:=Range("A4"), DataType:=xlDelimited, Other:=True, OtherChar:="|", FieldInfo:=Array(1, 1)
End Sub
Keep EXCELing
@Kunde - simppelisti
Pythonilla menee simppelisti. Eiköhän Excelissäkin saa suunnilleen vastaavan. Tulostaa vaan silmukassa printin sijaan Range.Offsetilla soluihin. Ei ole nyt Excel-konetta lähistöllä, niin en voi itse kokeilla.
def main():
osoitteet="Nimi <[email protected]>; Nimi<[email protected]>; Nimi<[email protected]>"
for osoite in osoitteet.split(";"):
jaettuosoite=osoite.split("<")
spostiosoite=jaettuosoite[1].split(">")
print(jaettuosoite[0].strip(),spostiosoite[0].strip())
main()- Mailit_ojoon
Kiitos. Pitäisi perehtyä tuon Pythonin salaisuuksiin. Mulla on kyllä joku aloittelijan ohje, joten puuttuu enää ryhtyminen toimeen. :)
- Kundepuu
tossa vielä poistettu turhat rivit
PutsaaEmailit()
Dim Email As Variant
Dim Putsattu As String
Putsattu = Replace(Range("A1"), ">", "")
Email = Split(Putsattu, ";")
Range("A4").Resize(UBound(Email) 1).Value = Application.WorksheetFunction.Transpose(Email)
Range("A4").Resize(UBound(Email) 1).TextToColumns Destination:=Range("A4"), DataType:=xlDelimited, Other:=True, OtherChar:="<", FieldInfo:=Array(1, 1)
End Sub- Mailit_ojoon
Jep. Nyt pelittää niinkuin halusin. Kiitos Kunde
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Toiko Helen laivalastillisen vieraslajeja Suomeen?
Loviisan satamaan tuotiin laivalastillinen pähkinänkuoria Norsunluurannikolta Loviisan satamaan kiinnittyi vapun al1423477Riikka runnoo: datakeskuksille tulee UUSI yritystuki
"Suomen valtio erikseen tukee esimerkiksi kryptovaluuttaan tai aikuisviihteeseen tai muuhun keskittyviä datakeskuksia.",42473Elikkä Riikka Purra ei kannusta Suomea edes euroviisuissa
Sellaista on persujen "isänmaallisuus", oma kansa viimeiseksi ja ulkomaalaiset ensimmäisiksi. https://www.iltalehti.fi/842190Koulujen kesälomien siirto
Koulujen kesälomaa voitaisiin siirtää viikon verran. Se voisi olla hyvä kompromissi. Pääsiäsiseen voitaisiin lisätä muut1371845- 1291812
Riikka: 3 euron bensa, Ruotsi: bensavero jopa alle EU-minimin
Eipä vaan suomalainen autoilija saa kaikkien rakastamalta Riikalta sympatiaa. Ruotsissa on eri meininki, siellä diskutee281729- 1381395
Victoria-tytär, 16, vertaa Martina Aitolehteä ja Esko Eerikäistä: "Iskä on enemmän..."
Martina Aitolehti ja Esko Eerikäinen ovat ex-pari ja heillä on yksi yhteinen tytär, Victoria. Eerikäinen oli Huomenta Su1131329"UKRAINA HYÖKKÄÄ LATVIAN ÖLJYVARASTOON JA JUNAAN"!!!
"MATKUSTAJAJUNA SAI UKRAINALAISLENNOKEISTA VAKAVIA VAURIOITA"!!!551196Nainen, mistä johtuu että joskus et vain ymmärrä?
Älä sitä, älä tätä. Ei niitä varoituksia turhaan sanota. Älä laita sormeasi sirkkeliin. Älä hengaile sen murhaaja poruka1571103