Completato

Note

Errore

Session expiration Your session is going to expireClick here to extend

Budget:

Piccolo progetto <800

Pubblicato il

07/03/12 15.18

Cliente

kao***

Questo progetto è scaduto

Pubblica un progetto simile e ricevi velocemente offerte non vincolanti.

Pubblica ora il tuo progetto simile

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. 

 

2)La seconda parte riguarda la ricerca del baricentro.Vi posto il codice 
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. 

 

 

4)Infine viene la parte che non è indispensabile ovvero la compilazione dell'ultima tabella.Quest'ultima tabella praticamente date le componenti x e y tra 2 reparti mi dovrebbe calcolare il modulo ovvero la radice quadrata di quadro più y quadro. 
 
In sintesi dovrebbero apparire su un foglio di lavoro 3 pulsanti.Uno per l'immissione dei reparti e la generazione delle matrici sull'altro foglio.Un'altro per la ricerca del baricentro e un altro per il calcolo delle distanze e la compilazione automatica delle 3 tabelle.La tabella da compilare nella quarta parte non è fondamentale.Da ricordare anche che si genera anche una quarta tabella dove si inseriscono alcuni dati manualmente dall'utente.