tekst naar kolommen

[Excelebeginner]

hallo,

ik heb een excel bestand waar ik bestandsnamen van foto's in delen opsplits om zo zo te kunnen koppelen aan de juiste serie waar ze in moeten worden geupload.

de bestandnamen zien er als het volgende uit,

20200117 - SW23941.jpg
20200117 - SW24992, SW105465.jpg
20200117 - SW2796, SW111032.jpg
20200117 - SW48096.jpg
20200117 - SW54195, SW68351.jpg
20200117 - SW89009.jpg
20200117 - SW95532, SW110886.jpg
20200117 - 0261520, SW228060.jpg
20200117 - 0290272, 0315325.jpg
20200117 - 0701538.jpg
20200117 - 0701561.jpg

ik haal eerst de datum en de .jpg eruit en de tekens die ik overhoud splits ik in verschillende kolommen.
nu heb ik een macro opgenomen met de functie tekst naar kolommen en voor de bestandsnamen die beginnen
met een letter werkt dat perfect maar voor de bestandsnamen die beginnen met een 0 valt de 0 steeds weg.
0261520, SW228060 wordt 261520 SW228060.

de kolommen staan ingesteld als tekst maar dit verhelpt het probleem niet, heeft iemand misschien een idee waarmee dit lukt, liefst in een macro

Alvast bedankt.

 

[Haije]

Excelbeginner,

welkom op Helpmij.nl!

Het is een goede gewoonte om je vraag ook te illustreren in een Excel(voorbeeld)bestand zonder gevoelige informatie.

Dan kunnen we ook je macro zien en evt aanpassen

 

[Senso]

Welkom.

Heb je deze gelezen? Plaats een voorbeeldbestand zonder privé-gegevens.

 

[Excelebeginner]

voorbeeld bestand

ik heb alle verschilende stukken code onder een apparte knop gezet zodat ik het apart kan testen en kan zien waar het mis gaat, op het eind wil ik een macro maken die automatisch draait wanneer het bestand wordt geopend, het gaat nu om de macro onder het kopje sorteren

 

[Haije]

probeer deze eens door op knop HS te klikken en kijk als het naar wens is naar de HS_module

 

[cow18]

Sub Tekst2Kolommen()
  With Columns("A")
      .Resize(, 5).NumberFormat = "@"
      .Replace ".jpg", ""
      .Replace " - ", "|"
      .Replace ", ", "|"
      .TextToColumns .Range("B1"), , , 0, 0, 0, 0, 0, 1, "|", Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1))
   End With
End Sub

 

[JEC.]

=SUBSTITUEREN(DEEL(SUBSTITUEREN("|"&SUBSTITUEREN(SUBSTITUEREN(SUBSTITUEREN($A2;" - ";"|");",";"|");".jpg";"")&"@";"|";HERHALING("@";200));KOLOM(A1)*200;200);"@";"")

Voor de liefhebber met formule in B1 en doortrekken

 

[Excelebeginner]

@Haije bij jou macro neemt die de 0 wel mee dus dat is goed maar wel staat er nu ook de .jpg in de verschillende kolommen het zou mooi zijn als dit er nog uit kon.

@cow18 bij jou code haalt die wel de .jpg weg maar neemt die de 0 niet mee.

kan het zijn dat dit aan de instellingen ligt of ontbreekt dit gewoon aan de code?

Wel alvast bedankt iig deze codes zien er al een stuk beter uit dat wat ik zelf had gefabriceerd

 

[Excelebeginner]

@ JVeer Deze formule werkt en neemt de 0 mee. heel erg bedankt

kan iemand mij misschien nog helpen om vervolgens de resultaten in al deze kolommen in 1 kolom onder elkaar te krijgen op een nieuw tabblad

 

[cow18]

zonder vooraf in kolommen te splitsen

Sub In_1_kolom()
   a = Sheets("blad1").Range("A1").CurrentRegion.Value   'alles in array lezen
   For i = 2 To UBound(a)                        'l voor 1 aflopen
      sp = Split(a(i, 1), " - ")                 'splitsen op die " - "
      If UBound(sp) = 1 Then s = s & "," & sp(1)   '2e deel verzamelen in een string met "," als separator
   Next
   b = Split(Mid(s, 2), ",")                     'alles terug in stukjes knippen op die ","

   With Sheets.Add.Range("A1")                   'nieuw werkblad
      .EntireColumn.NumberFormat = "@"           'kolom op tekst zetten
      .Resize(UBound(b) + 1).Value = Application.Transpose(b)   'knipsels wegschrijven
   End With
End Sub

kleine aanpassing, het moest nog in een nieuw werkblad zijn

 

[Excelebeginner]

@cow18
dit is bijna perfect alleen staat de .jpg er nog achter als je nog iets daarvoor hebt?

De volgende stap wat ik met de code moet doen is dat de bestandsnamen die hetzelfde zijn maar -1, -2 , -3 enz. erachter hebben in de kolommen achter de bestandsnaam die gelijk is maar dat niet erachter heeft.

vb.

HA1192524
HA1192524-2
HA1192524-3
HA1192524-4
HA1192524-5

wordt
HA1192524 HA1192524-2 HA1192524-3 HA1192524-4 HA1192524-5

 

[Excelebeginner]

update

ik heb met formules de spaties en de .jpg eruit weten te halen
in cel b1 =SPATIES.WISSEN(A1)
in cel c1=ALS(RECHTS(B1;4)=".jpg";LINKS(B1;LENGTE(B1)-4);B1)

dus alleen nog het sorteren van de -1, -2, -3 bestanden lukt me nog niet.

 

[JEC.]

Jouw twee formules kunnen in 1 formule in B1

=SPATIES.WISSEN(SUBSTITUEREN(A1;".jpg";""))

 

[cow18]

Sub In_1_kolom()
   a = Sheets("blad1").Range("A1").CurrentRegion.Value   'alles in array lezen
   For i = 2 To UBound(a)                        'l voor 1 aflopen
      sp = Split(a(i, 1), " - ")                 'splitsen op die " - "
      If UBound(sp) = 1 Then s = s & "," & sp(1)   '2e deel verzamelen in een string met "," als separator
   Next
   b = Split([COLOR="#FF0000"]Replace([/COLOR]Mid(s, 2)[COLOR="#FF0000"], ".jpg", "")[/COLOR], ",")                   'alles terug in stukjes knippen op die "," en de ".jpg3 verwijderen

   With Sheets.Add.Range("A1")                   'nieuw werkblad
      .EntireColumn.NumberFormat = "@"           'kolom op tekst zetten
      .Resize(UBound(b) + 1).Value = Application.Transpose(b)   'knipsels wegschrijven
   End With
End Sub

 

[JEC.]

Zo voldoende?

 

[HSV]

In de code van @cow18, verder heb ik er niet naar gekeken.

If UBound(sp) = 1 Then s = s & "," & [COLOR=#ff0000]Replace([/COLOR]sp(1)[COLOR=#ff0000], ".jpg", "")[/COLOR]

 

[cow18]

en nog op 1 rij gezet

Sub In_1_kolom()
   a = Sheets("blad1").Range("A1").CurrentRegion.Value   'alles in array lezen
   For i = 2 To UBound(a)                        'l voor 1 aflopen
      sp = Split(a(i, 1), " - ")                 'splitsen op die " - "
      If UBound(sp) = 1 Then s = s & "," & sp(1)   '2e deel verzamelen in een string met "," als separator
   Next
   b = Split(Replace(Mid(s, 2), ".jpg", ""), ",")   'alles terug in stukjes knippen op die "," en de ".jpg3 verwijderen

   Set dict = CreateObject("scripting.dictionary")
   For i = 0 To UBound(b)
      b0 = Split(b(i), "-")(0)
      If Not dict.exists(b0) Then
         dict.Add b0, b(i)
      Else
         dict(b0) = dict(b0) & "|" & b(i)
      End If
   Next

   With Sheets.Add.Range("A1")                   'nieuw werkblad
      .Resize(, 5).EntireColumn.NumberFormat = "@"   'kolom op tekst zetten
      With .Resize(dict.Count)
         .Value = Application.Transpose(dict.items)   'knipsels wegschrijven
         .TextToColumns Destination:=.Range("B1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
      End With
      .Resize(, 5).EntireColumn.AutoFit
   End With

End Sub

 

[Excelebeginner]

@cow18
is het nog mogelijk om de uitkomst weg te schrijven in een specifiek tabblad, nu opent die iedere keer een nieuw tabblad en zelfs als ik dat tabblad verwijder is het de volgende keer dat ik de macro draai niet tabblad 2 maar tabblad 3.

voor de rest helemaal perfect.

iedereen heel erg bedankt voor de hulp

 

[cow18]

je vraagt, wij draaien
vervang gewoon

With Sheets.Add.Range("A1") 
door 
With Sheets("De naam van mijn blad").Range("A1")

 

[Excelebeginner]

super, heel erg bedankt voor alle hulp, nu heb ik precies wat ik nodig heb.:d