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

259

    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 <[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

    1. Et siis vieläkään

      Et ilmeisesti ole vieläkään päässyt loppuun asti mun kirjoituksissa täällä. Kerro ihmeessä sit, kun valmista 😁 tuskin k
      Ikävä
      51
      2264
    2. Hyvä että lähdit siitä

      Ties mitä oisin keksinyt jos oisit jäänyt siihen, näit varmaan miten katoin sua.... 😘🤭😎💖
      Ikävä
      25
      1078
    3. Aavistatko että moni tietää

      Vai ollaanko hyvin vedätetty pokerinaamalla. No kun vähiten odotat niin yllätämme sinut
      Ikävä
      82
      992
    4. Yritin saada

      Vastauksia mutta et voinut olla rehellinen ja kaiken kannoin yksin. Halusin kovasti ymmärtää mutta en voi enää ymmärtää.
      Ikävä
      11
      914
    5. Koronarokotus sattui oudon paljon nyt sairaanhoitaja Tanja 46 istuu pyörätuolissa

      Pitkä piina piikistä Kun Tanja Vatka käy suihkussa, tuntuu kuin ihoa revittäisiin raastinraudalla irti. Hän on kärsinyt
      Maailman menoa
      54
      893
    6. Onko vielä

      mahdollista nähdä?
      Rakkaus ja rakastaminen
      68
      873
    7. Olisitko mies valmis?

      Maksamaan naisellesi/vaimollesi/tyttöystävällesi elämisestä syntyvät kulut, ruokailun, vuokran ja muut välttämättömät me
      Ikävä
      126
      853
    8. Kronikat..

      Mikä hele… on tää yks kronikat mikä suoltaa facessa kaikkea julkaisua ja AINA samoista firmoista imatralla??? Eikö ne mu
      Imatra
      10
      783
    9. vieläkin sanoa voin...

      💖💛💖💛💖💛💖💛💖 💛 Beijjjbeh 💛 Kaks vuotta tänään täällä. Miten hitossa jotkut on jaksaneet kymmeniä vuos
      Ikävä
      22
      773
    10. Täällä istun ja mietin

      Miten paljon haluaisin katsoa sinua juuri niin kuin haluaisin katsoa sinua. Rakastavin silmin. Näkisit vihdoin senkin pu
      Ikävä
      49
      759
    Aihe