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

212

Äänestä

    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ä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Kiitos nainen

      Kuitenkin. Olet sitten ajanmerkkinä. Tuskin enää sinua näen ja huomasitko, että olit siinä viimeisen kerran samassa paik
      Tunteet
      12
      3790

    2. MTV: Kirkossa saarnan pitänyt Jyrki 69 koki yllätyksen - Paljastaa: "Se mikä oli hyvin erikoista..."

      Jyrki Linnankivi alias Jyrki 69 on rokkari ja kirkonmies. Teologiaa opiskeleva Linnankivi piti elämänsä ensimmäisen saar
      Maailman menoa
      78
      1997

    3. Hyväksytkö sinä sen että päättäjämme ei rakenna rauhaa Venäjän kanssa?

      Vielä kun sota ehkäpä voitaisiin välttää rauhanponnisteluilla niin millä verukkeella voidaan sanoa että on hyvä asia kun
      Maailman menoa
      543
      1610

    4. Kirjoita yhdellä sanalla

      Joku meihin liittyvä asia, mitä muut ei tiedä. Sen jälkeen laitan sulle wappiviestin
      Ikävä
      83
      1267

    5. Olet hyvin erilainen

      Herkempi, ajattelevaisempi. Toisaalta taas hyvin varma siitä mitä haluat. Et anna yhtään periksi. Osaat myös ilkeillä ja
      Ikävä
      67
      1077

    6. Yksi syy nainen miksi sinusta pidän

      on se, että tykkään luomusta. Olet luonnollinen, ihana ja kaunis. Ja luonne, no, en ole tavannut vielä sellaista, joka s
      Ikävä
      33
      1018

    7. Hyödyt Suomelle???

      Haluaisin asettaa teille palstalla kirjoittelevat Venäjää puolustelevat ja muut "asiantuntijat" yhden kysymyksen pohditt
      Maailman menoa
      214
      898

    8. Hyvää Joulua mies!

      Toivottavasti kaikki on hyvin siellä. Anteeksi että olen hieman lisännyt taakkaasi ymmärtämättä kunnolla tilannettasi, o
      Ikävä
      60
      873

    9. Hyvää talvipäivänseisausta

      Vuoden lyhyintä päivää. 🌞 Hyvää huomenta. ❄️🎄🌌✨❤️😊
      Ikävä
      171
      854

    10. Paljastavat kuvat Selviytyjät Suomi kulisseista - 1 päivä vs 36 päivää viidakossa - Katso tästä!

      Ohhoh! Yli kuukausi viidakossa voi muuttaa ulkonäköä perusarkeen aika rajusti. Kuka mielestäsi muuttui eniten: Mia Mill
      Suomalaiset julkkikset
      3
      798
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt