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

255

    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. Hengenvaaralliset kiihdytysajot päättyivät karmealla tavalla, kilpailija kuoli

      Onnettomuudesta on aloitettu selvitys. Tapahtuma keskeytettiin onnettomuuteen. Tapahtumaa tutkitaan paikan päällä yhtei
      Kauhava
      183
      6622
    2. Ootko rakastunut?

      Kerro pois nyt
      Ikävä
      151
      1841
    3. Onhan sulla nainen parempi mieli

      Nyt? Ainakin toivon niin.
      Ikävä
      113
      1608
    4. Ujosteletko tosissaan vai mitä oikeen

      Himmailet???? Mitä pelkäät?????
      Ikävä
      51
      1330
    5. Suureksi onneksesi on myönnettävä

      Että olen nyt sitten mennyt rakastumaan sinuun. Ei tässä mitään, olen kärsivällinen ❤️
      Ikävä
      48
      1059
    6. Möykkähulluus vaati kuolonuhrin

      Nuori elämä menettiin täysin turhaan tällä järjettömyydellä! Toivottavasti näitä ei enää koskaan nähdä Kauhavalla! 😢
      Kauhava
      41
      991
    7. Älä mies pidä mua pettäjänä

      En petä ketään. Älä mies ajattele niin. Anteeksi että ihastuin suhun varattuna. Pettänyt en ole koskaan ketään vaikka hu
      Ikävä
      98
      952
    8. Reeniähororeeniä

      Helvetillisen vaikeaa työskennellä hoitajana,kun ei kestä silmissään yhtään läskiä. Saati hoitaa sellaista. Mitä tehdä?
      Kouvola
      5
      889
    9. Tarvitsemme lisää maahanmuuttoa.

      Väestö eläköityy, eli tarvitsemme lisää tekeviä käsiä ja veronmaksajia. Ainut ratkaisu löytyy maahanmuutosta. Nimenomaan
      Maailman menoa
      248
      881
    10. Kävit nainen näemmä mun

      Facessa katsomassa....
      Ikävä
      41
      849
    Aihe