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
239
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 <sp.osoite@posti.fi>; Nimi<sp.osoite@posti.fi>; Nimi<sp.osoite@posti.fi> jne...
Nimi ja sähköpostiosoite pitäisi saada eri sarakkeisiin muotoon
Nimi sp.osoite@posti.fi
Nimi sp.osoite@posti.fi
Nimi sp.osoite@posti.fi
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 <sp.osoite@posti.fi>; Nimi<sp.osoite@posti.fi>; Nimi<sp.osoite@posti.fi>"
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
Ja taas ammuttu kokkolassa
Kokkolaisilta pitäisi kerätä pois kaikki ampumaset, keittiöveitset ja kaikki mikä vähänkään paukku ja on terävä.313942Kuinka kauan
Olet ollut kaivattuusi ihastunut/rakastunut? Tajusitko tunteesi heti, vai syventyivätkö ne hitaasti?1131523Milli-helenalla ongelmia
Suomen virkavallan kanssa. Eipä ole ihme kun on etsintäkuullutettu jenkkilässäkin. Vähiin käy oleskelupaikat virottarell2421456Helena Koivu on äiti
Mitä hyötyä on Mikko Koivulla kohdella LASTENSA äitiä huonosti . Vie lapset tutuista ympyröistä pois . Lasten kodista.1771203Ja taas kerran hallinto-oikeus että pieleen meni
Hallinto-oikeus kumosi kunnanhallituksen päätöksen vuokratalojen pääomituksesta. https://sysmad10.oncloudos.com/cgi/DREQ80990Purra saksii taas. Hän on mielipuuhassaan.
Nyt hän leikkaa hyvinvointialueiltamme kymmeniä miljoonia. Sotea romutetaan tylysti. Terveydenhoitoamme kurjistetaan. ht254968Löydänköhän koskaan
Sunlaista herkkää tunteellista joka jumaloi mua. Tuskin. Siksi harmittaa että asiat meni näin 🥲116965Kun näen sinut
tulen iloiseksi. Tuskin uskallan katsoa sinua, herätät minussa niin paljon tunteita. En tunne sinua hyvin, mutta jotain34943- 62939
Kaipaan sua, Jii
Haluaisin vaan olla sylissäsi ja kuunnella mitä ajattelet, mistä haaveilet, mistä olet huolissasi jne 🥹 🫂56775