VBA: tekst voor celwaarde plakken (indien gevuld)

Status
Niet open voor verdere reacties.
globe

globe

Verenigingslid
Lid geworden
18 mrt 2001
Berichten
3.584
Ik gebruik al jaren een script om cellen waar een bepaalde waarde, in dit geval bestandsnaam.jpg, in staat te voorzien van een webadres.
Lege cellen worden overgeslagen.

Ooit geknipt van helpmij hier;)

Dus afbeelding.jpg wordt dan webadres/afbeelding.jpg in mijn voorbeeld gebeurt dit in kolom E

Nieuwe situatie:

- Met een upgrade van mijn systeem is het mogelijk om meerdere afbeeldingen in 1 cel te plakken, echter werkt mijn script dan niet meer omdat er aan de hele celwaarde het webadres wordt toegevoegd.
- tevens is het mogelijk om andere bestandsextesties te uploaden, dus er moet nu naar extensies .jpg / .eps / . psd / .png gekeken worden. Andere extensies mogen niet, dus naar 'niet' lege cellen kijken
- ik wil een range aangeven waarin gekeken moet worden, nu kopieer ik het script telkens om naar een andere kolom te kijken, dat werkte prima omdat ik vaste kolommen had, deze zijn echter nu variabel geworden.

het script wat ik nu gebruik (van toepassing op kolom E)

Code: 
Sub AddWebadres()
    Dim i As Long
    With ActiveSheet
        For i = 2 To .Cells(.Rows.Count, "e").End(xlUp).Row
            If Right(.Cells(i, 5), 4) = ".jpg" Then
                .Cells(i, 5) = "webadres/" & .Cells(i, 5)
            End If
        Next i
    End With
End Sub
 

Bijlagen

  • voorbeeld_helpmij_webadres_VBA.xlsm
    16,5 KB · Weergaven: 27
Laatst bewerkt:
Verplaatst
 
Code: 
Sub webadres_range()


'Best used when you want to include all data stored on the spreadsheet

Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set sht = Worksheets("Blad1")
Set StartCell = Range("c2")

'Refresh UsedRange
  Worksheets("Blad1").UsedRange

'Find Last Row and Column
  LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
  LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column

'Select Range
  sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
  


Dim c As Range

For Each c In Selection
If Right(c.Value, 4) = ".jpg" Or Right(c.Value, 4) = ".psd" Or Right(c.Value, 4) = ".png" Or Right(c.Value, 4) = ".eps" Then c.Value = "webadres/" & c.Value
Next
End Sub

weer een stap verder, ik kan nu een range aangeven, en de gewenste extensies selecteren.

Blijft de vraag staan hoe ik meerdere waardes in een cel van een pre-tekst voorzie.
Denk ik verkeerd en moet ik wellicht met zoeken en vervangen wat doen?
 
Laatst bewerkt:
zo ?
 

Bijlagen

  • voorbeeld_helpmij_webadres_VBA.xlsm
    22 KB · Weergaven: 24
Code: 
Sub webadres_range()


'Best used when you want to include all data stored on the spreadsheet

Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set sht = Worksheets("Blad1")
Set StartCell = Range("c2")

'Refresh UsedRange
  Worksheets("Blad1").UsedRange

'Find Last Row and Column
  LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
  LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column

'Select Range
  sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
  


Dim c As Range

For Each c In Selection
If Right(c.Value, 4) = ".jpg" Or Right(c.Value, 4) = ".psd" Or Right(c.Value, 4) = ".png" Or Right(c.Value, 4) = ".eps" Then c.Value = "webadres/" & c.Value
Next

Range("E:E").Replace What:=Chr(10), Replacement:=Chr(10) & "webadres/"

End Sub
 
Laatst bewerkt:
Loopt als een trein, maar moest wel even screenupdate uitzetten anders duurde het erg lang.

Topcode! Mooi om te zien dat het altijd korter kan. Ik ben niet zo'n held in VBA en was al blij dat ik zo ver kwam.

nog 1 klein dingetje.

Ik dacht dat mijn cellen allemaal Linebreaks hadden CHr(10) maar het blijkt dat er ook Chr(13) tussen zitten.

In mijn code heb ik dit opgevangen door dit te gebruiken:

Code: 
Range("E:E").Replace What:=Chr(10), Replacement:=Chr(10) & "webadres/"
Range("E:E").Replace What:=Chr(13), Replacement:=Chr(10) & "webadres/"

in jouw code krijg ik dit helaas niet werkend.
Zou je nog één keer willen kijken?

dank,

Guido
 
Laatst bewerkt:
In de code van @cow18

Code: 
sp = Split(Replace(c.Value, Chr(13), Chr(10)), Chr(10))
 
nog herinneringen aan die oude tikmachines van vroeger en het verschil tussen een nieuwe lijn(=vblf) en een nieuwe lijn + de ganse bovenbouw (=carriage), of hoe noem je dat ding, naar links (=vbCrlf.
Code: 
Replace(c.value,vbCrLf, VbLf)
Code: 
Constant   Value               Description
 ----------------------------------------------------------------
 vbCr       Chr(13)             Carriage return
 vbCrLf     Chr(13) & Chr(10)   Carriage return–linefeed combination
 vbLf       Chr(10)             Line feed
 
Laatst bewerkt:
De 'wagen' van de typemachine.
Eerst de wagen verplaatsen naar rechts: vbCr
Dan de hendel van de wagen doordrukken zodat de rol draaide: vbLf.
 
Laatst bewerkt:
Nee hoor, je moet de wagen met je linkerhand naar rechts verplaatsen om de letter'hamers' weer een de linkerkant van het papier te krijgen.
 
:eek: Even wat filmpjes opgezocht in google, inderdaad, ik had het fout.
Maar ja, een mechanische typmachine, dat is 40-50 jaar verleden tijd bij mij ...
 
Doe je maar ouder voor dan je bent .....
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan