Moderatori: Anthony47, Flash30005
Dim Sedi() As String
Option Explicit
Sub WFSede()
Dim CSede As Long, DBase As String, ColNomi As String, mySede As Range
Dim cWeek As Long, myName As String, LastR As Long, Weeks As String, I As Long
'
ReDim Sedi(1 To 100)
DBase = "base DATI" '<<< Il foglio col data base
ColNomi = "F" '<<< La colonna con i nominativi
'
Sheets(DBase).Select
LastR = Cells(Rows.Count, ColNomi).End(xlUp).Row
Weeks = Range(Cells(1, ColNomi).Offset(0, 2), Cells(1, ColNomi).End(xlToRight)).Address
For Each mySede In Range(Weeks).Offset(1, 0).Resize(LastR - 1)
If mySede.Value <> "" Then
If newSede(mySede) Then
On Error Resume Next
Sheets(mySede.Value).Select
On Error GoTo 0
If ActiveSheet.Name <> mySede.Value Then
Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = mySede.Value
End If
Sheets(mySede.Value).Cells.Clear
Range("A2").Resize(Range(Weeks).Count, 1) = Application.WorksheetFunction.Transpose(Sheets(DBase).Range(Weeks).Value)
CSede = CSede + 1
Sedi(CSede) = mySede.Value
End If
Sheets(mySede.Value).Select
With Sheets(DBase)
cWeek = .Cells(1, mySede.Column): myName = .Cells(mySede.Row, ColNomi).Value & " " & .Cells(mySede.Row, ColNomi).Offset(0, 1).Value
Cells(Application.Match(cWeek, Range("A1:A1000"), 0), Columns.Count).End(xlToLeft).Offset(0, 1) = myName
End With
End If
Next mySede
For I = 1 To UBound(Sedi, 1)
If Sedi(I) <> "" Then
Sheets(Sedi(I)).Cells.EntireColumn.AutoFit
End If
Next I
End Sub
Function newSede(ByVal WSede As String) As Boolean
Dim pippo
pippo = Application.Match(WSede, Sedi, 0)
If IsError(pippo) Then newSede = True Else newSede = False
End Function
ShKeep = "base" '<<< Il "prefisso" dei fogli da mantenere (almeno 3 caratteri)
rispo = MsgBox("Vuoi cancellare tutti i fogli il cui nome non inizia con " & ShKeep & "?" & vbCrLf & _
"Premi SI per confermare, premi NO per interrompere il processo", vbYesNo + vbCritical)
If rispo <> vbYes Then Exit Sub
If Len(ShKeep) < 3 Then Exit Sub
Application.DisplayAlerts = False
For I = ThisWorkbook.Worksheets.Count To 1 Step -1
If Len(Sheets(I).Name) > 3 Then
If UCase(Left(Sheets(I).Name, Len(ShKeep))) <> UCase(ShKeep) Then
Sheets(I).Delete
End If
End If
Next I
Application.DisplayAlerts = False
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Perchè l'importazione dati con Selenium non fuziona? Autore: aggittoriu |
Forum: Applicazioni Office Windows Risposte: 7 |
copia di dati da un file chiuso e elaborazione Autore: luca62 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 32 ospiti