Descrizione
Ciao a tutti! Dovrei implementare una macro complessa con vba per excel e mi servirebbe il vostro aiuto.Cerco di essere il più chiaro possibile suddividendo la spiegazione di ciò che mi serve in vari step.
1)Per cominciare bisogna creare un pulsante associato ad una macro che chiede in input di immettere il numero di Reparti. Per reparto intendo un range di celle avente lo stesso valore.Posto l'immagine per farvi capire meglio (immagine1)
Come vedete i reparti sono evidenziati con lo stesso valore e formano figure rettangolari o quadrate.Tra un reparto e un altro possono esserci anche delle celle vuote. La disposizione dei reparti avviene manualmente e a piacere da parte dell'utente.Se l'utente mette sul foglio di lavoro più o meno reparti di quelli che sono stati digitati appare un msg di errore. L'area dove si possono posizionare i reparti deve essere abbastanza grande. Dopo che l'utente ha inserito in input il numero di reparti quindi prima della disposizione manuale sul foglio di lavoro si generano 4 matrici quadrate aventi le dimensioni del numero di reparti immessi(se sono 5 allora 5x5...se sono 6 la dimensione sarà 6x6 e cosi via..) su un altro foglio.Il loro posizionamento è a piacere(possibilmente centrale). In una matrice si immettono dei valori in maniera manuale mentre le altre 3 devono essere immessi dalla macro.
Immagine3
In questa immagine abbiamo 5 reparti e sono state create soltanto 2 tabelle invece devono essere quattro e devono trovarsi su un altro foglio.
| Codice: |
| Option Explicit '--------------------------------------------------------------------------------------- ' Procedure : Baricentro ' Author : Scossa ' Date : 01/03/2012 ' Purpose : '--------------------------------------------------------------------------------------- ' Public Sub Baricentro(Optional ByRef rng As Range) Dim nCols As Long Dim nRows As Long Dim nCol As Long Dim nRow As Long Dim bOddCol As Boolean Dim bOddRow As Boolean Dim vColor As Variant On Error GoTo Baricentro_Error If rng Is Nothing Then Set rng = Selection If rng.Areas.Count > 1 Then Err.Raise vbObjectError + 513, _ Description:="selezionare solo celle contigue" nCols = rng.Columns.Count nRows = rng.Rows.Count If (nCols Mod 2) = 1 Then bOddCol = True If (nRows Mod 2) = 1 Then bOddRow = True nCol = Int(nCols / 2) + -bOddCol nRow = Int(nRows / 2) + -bOddRow Set rng = rng.Cells(nRow, nCol) If Not bOddCol Then Set rng = rng.Resize(1, 2) End If If Not bOddRow Then Set rng = rng.Resize(2) End If vColor = rng.Interior.Color rng.Interior.Color = rng.Font.Color rng.Font.Color = vColor 'rng.Select On Error GoTo 0 Baricentro_Error: If Err.Number <> 0 Then MsgBox "Errore: " & Err.Description, vbCritical, "Errore" End If Set rng = Nothing End Sub '--------------------------------------------------------------------------------------- ' Procedure : Aree ' Author : Scossa ' Date : 01/03/2012 ' Purpose : '--------------------------------------------------------------------------------------- ' Public Sub Aree(Optional ByRef rng As Range) Dim rArea As Range Dim rAree As Range Dim cella As Range Dim nSize As Long Dim bLoop As Boolean On Error GoTo Aree_Error If rng Is Nothing Then Set rng = Selection If rng.Areas.Count > 1 Then Err.Raise vbObjectError + 513, _ Description:="selezionare solo celle contigue" For Each cella In rng If rAree Is Nothing Then bLoop = True Else If Intersect(cella, rAree) Is Nothing Then bLoop = True End If If bLoop Then Set rArea = cella nSize = 1 Do While cella.Value = cella.Offset(nSize).Value nSize = nSize + 1 Set rArea = rArea.Resize(nSize) Loop nSize = 1 Do While cella.Value = cella.Offset(0, nSize).Value nSize = nSize + 1 Set rArea = rArea.Resize(, nSize) Loop If rAree Is Nothing Then Set rAree = rArea Else Set rAree = Union(rAree, rArea) End If Call Baricentro(rArea) bLoop = False End If Next Aree_Error: If Err.Number <> 0 Then MsgBox "Errore: " & Err.Description, vbCritical, "Errore" End If Set rng = Nothing Set rArea = Nothing Set cella = Nothing End Sub |
Questo è il file: http://uploading.com/files/aadb394a/Baricentro%2B%25282%2529.xls/" target="_blank">http://uploading.com/files/aadb394a/Baricentro%2B%25282%2529.xls/ Come potete vedere premendo sul command button e su una cella ricerca automaticamente il baricentro di ogni singola cella. Se l'altezza e la base è formata da un numero dispari di celle avremo un baricentro formato da un'unica cella,se una delle 2 è pari mentre l'altra è dispari 2 celle e infine se le dimensioni sono entrambe pari il baricentro sarà composto da 4 celle.
3)Successivamente bisogna creare un altro pulsante sul foglio di lavoro dove si associa il codice della seguente macro
| Codice: |
| Sub conta_celle() Dim x As Range Dim y As Range Dim rigaC1 As Long Dim rigaC2 As Long Dim colC1 As Long Dim colC2 As Long Dim diffCol As Long Dim diffRighe As Long On Error GoTo uscita Set x = Application.InputBox("Clicca sulla cella scelta", _ "SELEZIONE PRIMA CELLA", Type:=8) Set y = Application.InputBox("Clicca sulla cella scelta", _ "SELEZIONE SECONDA CELLA", Type:=8) rigaC1 = x.Row rigaC2 = y.Row colC1 = x.Column colC2 = y.Column diffCol = colC2 - colC1 diffRighe = rigaC2 - rigaC1 If rigaC2 < rigaC1 Then diffRighe = rigaC1 - rigaC2 If colC2 < colC1 Then diffCol = colC1 - colC2 MsgBox "La distanza delta X tra le 2 celle selezionate è di " _ & diffCol & " celle. " & vbLf & vbLf & _ "La distanza delta Y tra le 2 celle selezionate è di " _ & diffRighe & " celle. ", vbInformation, "RISULTATO" uscita: If Err.Number <> 0 Then MsgBox Err.Description End If Set x = Nothing Set y = Nothing End Sub |
Questo macro calcola le celle di distanza tra 2 selezionate, lungo l'asse x e y e richiede l'input tramite msgbox.Invece a me serve che le celle selezionate siano tutti i baricentri dei reparti e vengano calcolate automaticamente le distanze lungo x e y tra tutti i baricentri e che vengano compilate in 2 delle 4 matrici ideate inizialmente.Nella macro sopracitata invece i risultati escono in msg box Posto un esempio per farvi capire meglio! Userò per semplicità 3 reparti con dimensioni dispari!
immagine 5Inoltre sempre in questa macro si verifica un piccolo errore.Se come prima selezione prendo le celle A1 e B1 e come seconda selezione A8 mi da come distanza x 0 celle invece dovrebbe essere 0.5 perchè se prendiamo il baricentro dell'intervallo A1-B1 e quello di A8 la distanza è 0,5.