Estrarre solo il cognome per denominare cartella

Question

Estrarre solo il cognome per denominare cartella

Anonimo

Ciao a tutti,

Chiedo il vostro aiuto per poter modificare il codice nel file che allego e che potete scaricare da qui. Il codice è stato scritto da Norman, aggiungo anche che funziona in modo perfetto. Quello che chiedo è di avere la possibilità nel momento che crea le nuove cartelle di prendere il nome per la cartella dalla colonna filtrata la F cosa che già avviene, ma di mettere solo la prima parte, cioè il cognome. Tenendo in considerazione 2 aspetti:

Potrebbero esserci cognomi fatti di 2 parole come nell’esempio del file ho scritto “Di Maggio”.
Nel caso in cui ci fossero 2 persone con lo stesso cognome ma nomi diversi, solo per quelle cartelle che saranno create sarà incluso anche il nome per poterle distinguere.

Spero di essermi spiegato in modo esauriente visto che a volte vi rendiamo difficile il lavoro che eseguite a nostro favore. Grazie di tutto.

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Geacs,

Chiedo il vostro aiuto per poter modificare il codice nel file che allego e che potete scaricare da qui. Il codice è stato scritto da Norman, aggiungo anche che funziona in modo perfetto. Quello che chiedo è di avere la possibilità nel momento che crea le nuove cartelle di prendere il nome per la cartella dalla colonna filtrata la F cosa che già avviene, ma di mettere solo la prima parte, cioè il cognome. Tenendo in considerazione 2 aspetti:

Potrebbero esserci cognomi fatti di 2 parole come nell’esempio del file ho scritto “Di Maggio”.

Nel caso in cui ci fossero 2 persone con lo stesso cognome ma nomi diversi, solo per quelle cartelle che saranno create sarà incluso anche il nome per poterle distinguere.

Spero di essermi spiegato in modo esauriente visto che a volte vi rendiamo difficile il lavoro che eseguite a nostro favore.

Prova qualcosa del genere:

'=========>>

Option Explicit

Dim myWB As Workbook

Dim srcSH As Worksheet

Dim myRng As Range

Dim rngElenco As Range

Dim rngElenco2 As Range

Public Const iUltimaColonna As Long = 6 '\ Colonna F

'--------->>

Public Sub Tester()

Dim arrTabella As Variant, arrSorted As Variant

Dim aStr As String, sStr As String

Dim sNome As String, sCognome As String

Dim arrSplit As Variant, arrCognome() As String

Dim vVar As Variant

Dim arrKeys As Variant

Dim oDic As Object

Dim sOldSurname As String, sFullname As String

Dim LB As Long, UB As Long

Dim CalcMode As Long

Dim iStart As Long, iEnd As Long

Dim i As Long, j As Long, k As Long

Dim p As Long

Dim LRow As Long

Dim iRow As Long, jRow As Long

Dim bAscending As Boolean, bCreate As Boolean

Const iPrimaRiga As Long = 3

Const sPrimaColonnaTabella As String = "A" '<<=== Modifica

Const sColonnaElenco As String = "AA" '<<=== Modifica

Const sColonnaElenco2 As String = "AB" '<<=== Modifica

Const iRigaIntestazioniElenco As Long = 1 '<<=== Modifica

Const iRigaIntestazioniElenco2 As Long = 1 '<<=== Modifica

Const sFoglio As String = "Registrazione"

Set myWB = ThisWorkbook

Set srcSH = myWB.Sheets(sFoglio)

On Error GoTo XIT

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

With srcSH

LRow = LastRow(srcSH, .Columns(sPrimaColonnaTabella))

Set myRng = .Range(sPrimaColonnaTabella & iPrimaRiga). _

Resize(LRow - iPrimaRiga + 1, iUltimaColonna)

iRow = LastRow(srcSH, .Columns(sColonnaElenco))

jRow = LastRow(srcSH, .Columns(sColonnaElenco2))

Set rngElenco = .Range(sColonnaElenco _

& iRigaIntestazioniElenco + 1). _

Resize(iRow - iRigaIntestazioniElenco)

Set rngElenco2 = .Range(sColonnaElenco2 _

& iRigaIntestazioniElenco2 + 1). _

Resize(jRow - iRigaIntestazioniElenco2)

End With

arrTabella = myRng.Value

bAscending = True

arrSorted = arrTabella

Call QuickSort(arrSorted, _

iUltimaColonna, _

LBound(arrSorted, 1), _

UBound(arrSorted, 1), _

bAscending)

myRng.Value = arrSorted

Set oDic = CreateObject("Scripting.Dictionary")

oDic.CompareMode = vbTextCompare

With oDic

For j = LBound(arrSorted) To UBound(arrSorted)

sStr = arrSorted(j, iUltimaColonna)

aStr = Trim(sStr)

arrSplit = Split(aStr, Space(1))

LB = LBound(arrSplit)

UB = UBound(arrSplit)

ReDim arrCognome(1 To UB)

For k = LB To UB - 1

arrCognome(k + 1) = arrSplit(k)

Next k

sNome = arrSplit(UB)

sCognome = Join(arrCognome, Space(1))

If Not .exists(sCognome) _

And Not .exists(aStr) Then

oDic.Add Key:=sCognome, Item:=sNome

sOldSurname = sCognome

sFullname = aStr

ElseIf aStr <> sFullname Then

oDic.Add Key:=sFullname, Item:=Nothing

oDic.Add Key:=aStr, Item:=sNome

oDic.Remove (sOldSurname)

sFullname = aStr

End If

Next j

End With

arrKeys = oDic.keys

iStart = iPrimaRiga

For i = LBound(arrSorted, 1) + 1 To UBound(arrSorted, 1)

bCreate = False

If arrSorted(i, iUltimaColonna) = _

arrSorted(i - 1, iUltimaColonna) Then

If i = UBound(arrSorted, 1) Then

bCreate = True

iEnd = iPrimaRiga + i - 1

End If

Else

iEnd = iPrimaRiga + i - 2

bCreate = True

End If

If bCreate Then

sStr = arrSorted(i - 1, iUltimaColonna)

vVar = arrKeys(p)

Call CreateWorkbook(iStart, iEnd, vVar)

p = p + 1

bCreate = False

iStart = iEnd + 1

End If

Next i

myRng.Value = arrTabella

XIT:

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

End Sub

'--------->>

Public Sub CreateWorkbook( _

FirstRow As Long, _

EndRow As Long, _

Codice As Variant)

Dim newSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim rngConvalida As Range

Dim rngConvalida2 As Range

Dim arrIn As Variant, arrIn2 As Variant

Dim arrHeaders As Variant

Dim sElenco As String, sElenco2 As String

Dim sPercorso As String

Const sIntestazioni As String = _

"Nome,Operatore,Luogo," _

& "Appartenenza,Anzianità,Ore"

Const sColonnaConvalida As String = "E" '<<=== Modifica

Const sColonnaConvalida2 As String = "F" '<<=== Modifica

With Application

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

Set srcRng = Intersect(myRng, _

srcSH.Rows(FirstRow _

& ":" & EndRow))

Set newSH = myWB.Worksheets.Add

arrHeaders = Split(sIntestazioni, ",")

With newSH

.Range("A1").Resize(1, _

UBound(arrHeaders) + 1).Value _

= arrHeaders

Set destRng = .Range("A2"). _

Resize(EndRow - FirstRow + 1, _

iUltimaColonna)

srcRng.Copy destRng

.Copy

Application.DisplayAlerts = False

.Delete

Application.DisplayAlerts = True

End With

sPercorso = myWB.Path & Application.PathSeparator

With ActiveWorkbook

With .Sheets(1).UsedRange

Set rngConvalida = _

.Columns(sColonnaConvalida)

Set rngConvalida2 = _

.Columns(sColonnaConvalida2)

End With

arrIn = rngElenco.Value

arrIn2 = rngElenco2.Value

arrIn = Application.Transpose(arrIn)

arrIn2 = Application.Transpose(arrIn2)

sElenco = Join(arrIn, ",")

sElenco2 = Join(arrIn2, ",")

Call addValidation(rngConvalida, sElenco)

Call addValidation(rngConvalida2, sElenco2)

.Sheets(1).UsedRange.EntireColumn.AutoFit

.SaveAs Filename:=sPercorso _

& Codice & ".xlsx", _

FileFormat:=51

.Close

End With

End Sub

'--------->>

Public Sub QuickSort(SortArray, col, L, R, bAscending)

'\ TomOgilvy: http://goo.gl/ninpZW

'Originally Posted by Jim Rech 10/20/98 Excel.Programming

'Modified to sort on first column of a two dimensional array

'Modified to handle a second dimension greater than 1 (or zero)

'Modified to do Ascending or Descending

Dim i, j, X, Y, mm

i = L

j = R

X = SortArray((L + R) / 2, col)

If bAscending Then

While (i <= j)

While (SortArray(i, col) < X And i < R)

i = i + 1

Wend

While (X < SortArray(j, col) And j > L)

j = j - 1

Wend

If (i <= j) Then

For mm = LBound(SortArray, 2) To _

UBound(SortArray, 2)

Y = SortArray(i, mm)

SortArray(i, mm) = SortArray(j, mm)

SortArray(j, mm) = Y

Next mm

i = i + 1

j = j - 1

End If

Wend

Else

While (i <= j)

While (SortArray(i, col) > X And i < R)

i = i + 1

Wend

While (X > SortArray(j, col) And j > L)

j = j - 1

Wend

If (i <= j) Then

For mm = LBound(SortArray, 2) To _

UBound(SortArray, 2)

Y = SortArray(i, mm)

SortArray(i, mm) = SortArray(j, mm)

SortArray(j, mm) = Y

Next mm

i = i + 1

j = j - 1

End If

Wend

End If

If (L < j) Then Call QuickSort(SortArray, _

col, L, j, bAscending)

If (i < R) Then Call QuickSort(SortArray, _

col, i, R, bAscending)

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional rng As Range, _

Optional minRow As Long = 1, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If rng Is Nothing Then

Set rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

On Error Resume Next

LastRow = rng.Find(What:="*", _

after:=rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

'--------->>

Public Function addValidation( _

rng As Range, _

sList As String)

With rng.Validation

.Delete

.Add Type:=xlValidateList, _

AlertStyle:=xlValidAlertStop, _

Operator:=xlBetween, _

Formula1:=sList

.IgnoreBlank = True

.InCellDropdown = True

.InputTitle = ""

.ErrorTitle = ""

.InputMessage = ""

.ErrorMessage = ""

.ShowInput = True

.ShowError = True

End With

End Function

'<<=========

===

Regards,

Norman

0 commenti

1 risposta aggiuntiva

Answer 1

Anonimo

Ciao Norman,

Un Grande, Grande, Grande Grazie. È perfetto, l'ho provato e riprovato e risponde alla perfezione alla mia esigenza. Grazie per la tua disponibilità.

0 commenti