Moderatori: Anthony47, Flash30005
Tutto dipende dalla tua attuale conoscenza del vba: minima, mediocre, decorosa, soddisfacente, etc?nella mia mente è tutto lineare ma non so proprio da dove iniziare. Help me please!!!!
Sub CompilaTab()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim E As Integer: Dim J As Integer: Dim R As Integer
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set Ws1 = Sheets("Maschera")
Set Ws2 = Sheets("2011")
Set Ws3 = Sheets("Risultato")
Ws3.Select
Ws3.Cells.Clear
Ws2.Columns("A:P").Copy Destination:=Ws3.Columns("A:A")
Ws3.Range("A1:N1").UnMerge
For RM = 8 To 19
If Ws1.Range("H" & RM) <> "" Then
Mese = Ws1.Range("I" & RM).Value
GoTo SaltaRM
End If
Next RM
SaltaRM:
For RC = 8 To 12
If Ws1.Range("J" & RC) <> "" Then
Citta = Ws1.Range("K" & RC).Value
Citta = Mid(Citta, 1, 2)
GoTo SaltaRC
End If
Next RC
SaltaRC:
For CC = 14 To 3 Step -1
If Ws3.Cells(2, CC).Value <> Mese Then
Columns(CC).Delete Shift:=xlToLeft
End If
Next CC
UR3 = Ws3.Range("A" & Rows.Count).End(xlUp).Row
For RR = UR3 To 3 Step -1
If Ws3.Range("B" & RR).Value <> Citta Then Rows(RR & ":" & RR).Delete Shift:=xlUp
Next RR
Calculate
Ws3.Range("F2").Value = Ws1.Range("C7").Value
URS = Ws3.Range("E" & Rows.Count).End(xlUp).Row
For RRS = 3 To URS
Ws3.Range("F" & RRS).Value = Ws3.Range("F2").Value * Ws3.Range("E" & RRS).Value
Next RRS
Ws3.Range("F3:F" & URS).NumberFormat = "0.00"
Ws3.Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
CheckAreaM = "H8:H19"
CheckAreaC = "J8:J12"
If Not Application.Intersect(ActiveCell, Range(CheckAreaM)) Is Nothing Then
If (Selection.Rows.Count + Selection.Columns.Count) > 2 Then GoTo Citta
Application.EnableEvents = False
Range(CheckAreaM).ClearContents
If Selection.Value <> 0 Then
Selection.ClearContents
Else
Selection.Value = 1
End If
End If
Application.EnableEvents = True
Citta:
If Not Application.Intersect(ActiveCell, Range(CheckAreaC)) Is Nothing Then
If (Selection.Rows.Count + Selection.Columns.Count) > 2 Then Exit Sub
Application.EnableEvents = False
Range(CheckAreaC).ClearContents
If Selection.Value <> 0 Then
Selection.ClearContents
Else
Selection.Value = 1
End If
End If
Application.EnableEvents = True
End Sub
Avatar3 ha scritto:ammettendo di selezionare tutti i mesi e tutte le città ti ritroveresti un foglio simile ai dati origine con le incidenze identiche
Sub CompilaTab()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim E As Integer: Dim J As Integer: Dim R As Integer
Dim MeseV(12) As String
Dim CittaV(5) As String
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set Ws1 = Sheets("Maschera")
Set Ws2 = Sheets("2011")
Set Ws3 = Sheets("Risultato")
Ws3.Select
Ws3.Cells.Clear
Ws2.Columns("A:P").Copy Destination:=Ws3.Columns("A:A")
Ws3.Range("A1:N1").UnMerge
ContaM = 0
For RM = 8 To 19
If Ws1.Range("H" & RM) <> "" Then
ContaM = ContaM + 1
MeseV(ContaM) = Ws1.Range("I" & RM).Value
End If
Next RM
ContaC = 0
For RC = 8 To 12
If Ws1.Range("J" & RC) <> "" Then
ContaC = ContaC + 1
Citta = Ws1.Range("K" & RC).Value
CittaV(ContaC) = Mid(Citta, 1, 2)
End If
Next RC
For CC = 14 To 3 Step -1
For CMe = 1 To ContaM
If Ws3.Cells(2, CC).Value = MeseV(CMe) Then
GoTo SaltaM
End If
Next CMe
Columns(CC).Delete Shift:=xlToLeft
SaltaM:
Next CC
UR3 = Ws3.Range("A" & Rows.Count).End(xlUp).Row
For RR = UR3 To 3 Step -1
For CA = 1 To ContaC
If Ws3.Range("B" & RR).Value = CittaV(CA) Then
GoTo SaltaC
End If
Next CA
Rows(RR & ":" & RR).Delete Shift:=xlUp
SaltaC:
Next RR
Calculate
UC = Ws3.Range("IV2").End(xlToLeft).Column + 1
Ws3.Cells(2, UC).Value = Ws1.Range("C7").Value
URS = Ws3.Cells(Rows.Count, UC - 1).End(xlUp).Row
For RRS = 3 To URS
Ws3.Cells(RRS, UC).Value = Ws3.Cells(2, UC).Value * Ws3.Cells(RRS, UC - 1).Value
Next RRS
Ws3.Range(Cells(3, UC), Cells(URS, UC)).NumberFormat = "0.00"
Ws3.Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
CheckAreaM = "H8:H19"
CheckAreaC = "J8:J12"
If Not Application.Intersect(ActiveCell, Range(CheckAreaM)) Is Nothing Then
If (Selection.Rows.Count + Selection.Columns.Count) > 2 Then GoTo Citta
Application.EnableEvents = False
If Selection.Value <> 0 Then
Selection.ClearContents
Else
Selection.Value = 1
End If
End If
Application.EnableEvents = True
Citta:
If Not Application.Intersect(ActiveCell, Range(CheckAreaC)) Is Nothing Then
If (Selection.Rows.Count + Selection.Columns.Count) > 2 Then Exit Sub
Application.EnableEvents = False
If Selection.Value <> 0 Then
Selection.ClearContents
Else
Selection.Value = 1
End If
End If
Application.EnableEvents = True
End Sub
Ws3.Range(Cells(3, UC), Cells(URS, UC)).NumberFormat = "0.00"
Dim MeseV(12) As String
For RM = 8 To 19
If Ws1.Range("H" & RM) <> "" Then
ContaM = ContaM + 1
MeseV(ContaM) = Ws1.Range("I" & RM).Value
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
Problemi di stampa su carta adesiva lucida con Epson Et 2850 Autore: lukarello7 |
Forum: Discussioni Risposte: 5 |
Visitano il forum: Nessuno e 31 ospiti