Makron sieventämistä

Mailit_ojoon

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

7

239

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • 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

    1. 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ä.
      Kokkola
      31
      3942
    2. Kuinka kauan

      Olet ollut kaivattuusi ihastunut/rakastunut? Tajusitko tunteesi heti, vai syventyivätkö ne hitaasti?
      Ikävä
      113
      1523
    3. Milli-helenalla ongelmia

      Suomen virkavallan kanssa. Eipä ole ihme kun on etsintäkuullutettu jenkkilässäkin. Vähiin käy oleskelupaikat virottarell
      Kotimaiset julkkisjuorut
      242
      1456
    4. Helena Koivu on äiti

      Mitä hyötyä on Mikko Koivulla kohdella LASTENSA äitiä huonosti . Vie lapset tutuista ympyröistä pois . Lasten kodista.
      Kotimaiset julkkisjuorut
      177
      1203
    5. Ja taas kerran hallinto-oikeus että pieleen meni

      Hallinto-oikeus kumosi kunnanhallituksen päätöksen vuokratalojen pääomituksesta. https://sysmad10.oncloudos.com/cgi/DREQ
      Sysmä
      80
      990
    6. Purra saksii taas. Hän on mielipuuhassaan.

      Nyt hän leikkaa hyvinvointialueiltamme kymmeniä miljoonia. Sotea romutetaan tylysti. Terveydenhoitoamme kurjistetaan. ht
      Maailman menoa
      254
      968
    7. Löydänköhän koskaan

      Sunlaista herkkää tunteellista joka jumaloi mua. Tuskin. Siksi harmittaa että asiat meni näin 🥲
      Ikävä
      116
      965
    8. Kun näen sinut

      tulen iloiseksi. Tuskin uskallan katsoa sinua, herätät minussa niin paljon tunteita. En tunne sinua hyvin, mutta jotain
      Ikävä
      34
      943
    9. Yhdelle miehelle

      Mä kaipaan sua niin paljon. Miksi sä oot tommonen pösilö?
      Ikävä
      62
      939
    10. Kaipaan sua, Jii

      Haluaisin vaan olla sylissäsi ja kuunnella mitä ajattelet, mistä haaveilet, mistä olet huolissasi jne 🥹 🫂
      Ikävä
      56
      775
    Aihe