Puoi provare con questa macro:
- Codice: Seleziona tutto
Sub ULCaser()
Dim StarD As Range, Dest As Range, myC As Range
Dim xStra As String, ccStr As String
Dim iOut As Long, I As Long, gotLC As Boolean
'
Set StarD = Sheets("Foglio1").Range("N1") '<<< I dati di partenza
Set Dest = Sheets("Foglio1").Range("P1") '1 <<< La posizione di uscita
'Set Dest = Nothing '2 Per 1-2 vedi testo
xStra = "." '<<< La stringa da aggiungere
'
If Dest Is Nothing Then
Set Dest = StarD
Else
Dest.Resize(10000, 1).ClearContents
End If
Application.ScreenUpdating = False
iOut = 1
For Each myC In Range(StarD, StarD.Offset(10000, 0).End(xlUp))
ccStr = myC.Value
If Len(ccStr) > 0 Then
For I = 1 To Len(ccStr)
If Asc(Mid(ccStr, I, 1)) > 96 Then
Dest.Cells(iOut, 1) = ccStr & xStra
gotLC = True
Exit For
End If
Next I
If gotLC Then gotLC = False Else Dest.Cells(iOut, 1) = ccStr
End If
iOut = iOut + 1
Next myC
Application.ScreenUpdating = True
End Sub
Le righe marcate <<< vanno compilate con i tuoi dati.
In particolare le righe 1 e 2 sono alternative; nel senso che ho previsto che l'output possa essere generato in una nuova posizione (lasciando l'istruzione 1, correttamente compilata, e lasciando la posizione 2 "commentata", come e' adesso); questo serve soprattutto per il test.
Oppure togli l'Apostrofo in testa alla riga 2, cancelli o commenti la riga 1; in questo caso i dati di partenza vengono sovrascritti con i dati modificati.
Cioe':
- Codice: Seleziona tutto
'I dati vengono scritti nella nuova posizione indicata:
Set Dest = Sheets("Foglio1").Range("P1") '1 <<< La posizione di uscita
'Set Dest = Nothing '2 Per 1-2 vedi testo
OPPURE
- Codice: Seleziona tutto
'I dati di partenza vengono sovrascritti:
'Set Dest = Sheets("Foglio1").Range("P1") '1 <<< La posizione di uscita
Set Dest = Nothing '2 Per 1-2 vedi testo
Personalmente credo che i dati di partenza non debbano mai essere alterati
Prova...
Registrazione
