invertire valore range di celle

Versione Completa   Stampa   Cerca   Utenti   Iscriviti     Condividi : FacebookTwitter
sindaco77
00mercoledì 3 agosto 2016 16:58
Intanto buonasera!
premetto che sono un pò niubbo in materia, vi volevo esporre il mio problema!
ho bisogno di una macro che scambi il valore di due o tre celle (es. a1, b1, c1) con altrettante due o tre cell (es. m5, n5, o5).
Al momento ho questa macro

Sub inverti()
Dim cella1 As Variant
Dim cella2 As Variant
Dim cella As Range
Dim indir(2) As String
Dim i As Byte
If Selection.Count <> 2 Then
MsgBox "Devi selezionare esattamente due celle"
Exit Sub
End If
i = 0
For Each cella In Selection.Cells
indir(i) = cella.Address
i = i + 1
Next
cella1 = Range(indir(0)).Value
cella2 = Range(indir(1)).Value
Range(indir(1)).Value = cella1
Range(indir(0)).Value = cella2
End Sub

Seleziono una cella, tengo premuto tasto ctrl, seleziono la seconda cella e avvio la macro, ma posso selezionare solo una cella.
Ho trovato questa macro che forse fa a caso mio:

Public Sub SwapRanges()
Dim R1 As Range, R2 As Range, Rtemp As Range, Area As Areas
Dim Cell
Set Area = Selection.Areas
If Area.Count = 2 Then
Set R1 = Area(1)
Set R2 = Area(2)
Else
MsgBox "Occorre aver prima selezionato i due intervalli da scambiare!"
End If
If R1.Columns.Count = R2.Columns.Count And R1.Rows.Count = R2.Rows.Count Then
Set Rtemp = Range("ZZ1000").Resize(R1.Rows.Count, R1.Columns.Count)
Rtemp.Value = R1.Value
R1.Value = R2.Value
R2.Value = Rtemp.CurrentRegion.Value
Rtemp.ClearContents
Else
MsgBox "I due intervalli devono essere uguali!"
End If
Set R1 = Nothing
Set R2 = Nothing
Set Rtemp = Nothing
End Sub

ma non riesco a capire il funzionamento!
Chi mi puo dare una mano?
patel45
10mercoledì 3 agosto 2016 17:11
la seconda funziona bene, ma a te interessa selezionare i due range o averli fissi ? se fissi la macro si semplificherebbe molto-
Cosa non capisci ?
sindaco77
00mercoledì 3 agosto 2016 17:17
non sono fissi, devo poterli selezionare è quello il problema!
sindaco77
00mercoledì 3 agosto 2016 17:19
Comè il funzionamento della seconda funzione? Nel senso non so i passaggi che devo fare per attivarla!
patel45
00mercoledì 3 agosto 2016 17:19
non ho capito se non riesci a farla funzionare o se non capisci il codice
sindaco77
00mercoledì 3 agosto 2016 17:22
a farla funzionare!
patel45
00mercoledì 3 agosto 2016 17:24
seleziona col mouse il primo range, premi CTRL e seleziona il secondo, poi lancia la macro
sindaco77
00mercoledì 3 agosto 2016 17:27
mi da errore, mi da il simbolo del bollino rosso con una x bianca e affianco la scritta 400
patel45
00mercoledì 3 agosto 2016 17:33
a me funziona bene, allega il file con le spiegazioni di cosa fai
sindaco77
00mercoledì 3 agosto 2016 17:48
spero che labbia allegato il file!
Praticamente sul foglio frontale devo selezionare tre celle adiacenti e sostituirle con tre celle sempre adiancenti!
Ho selezionato tre celle in giallo!
mi è venuto il dubbio che il problema potrebbe essere provocato da un altra macro!
patel45
10mercoledì 3 agosto 2016 18:04
ecco perché il file è sempre necessario...
modifica così questa macro in modo da disabilitarla quando selezioni più celle

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Lc
If Target.Count > 1 Then Exit Sub ' <<<<<<<<<<<<<
    If Not Intersect(Target, [B3:B35,E3:E35,H3:H35,K3:K35,N3:N35,Q3:Q35,T3:T35,W3:W35]) Is Nothing Then

e metti quella dello swap nel modulo1 con questa modifica
    Set Rtemp = Range("AA1000").Resize(R1.Rows.Count, R1.Columns.Count)
sul 2003 non esiste la colonna ZZ
sindaco77
00mercoledì 3 agosto 2016 18:19
Posso farti una domanda!
Quale era il problema?
sindaco77
00mercoledì 3 agosto 2016 18:24
ah si ho capito! sulla versione 2003 non esiste quela colonna!
patel45
00mercoledì 3 agosto 2016 18:33
i problemi erano 2, uno è la colonna ZZ, l'altro è la selezione multipla che veniva intercettata dalla
Private Sub Worksheet_SelectionChange
sindaco77
00mercoledì 3 agosto 2016 18:39
ok grazie mille!
scossa
00giovedì 4 agosto 2016 11:19
Ciao,

propongo una semplificazione, mediante uso di array:

Public Sub Swap2Ranges()
  'by scossa
  
  Dim Area As Areas
  Dim aRng1 As Variant, aRng2 As Variant
  
  Set Area = Selection.Areas
  On Error GoTo safety_exit_
  If Area.Count <> 2 Then
    Err.Raise vbObjectError + 513, Description:="Selezionare due separati intervalli di celle!"
  ElseIf Not Intersect(Area(1), Area(2)) Is Nothing Then
    Err.Raise vbObjectError + 513, Description:="i due intervalli hanno celle in comune!"
  ElseIf Area(1).Rows.Count <> Area(2).Rows.Count Or Area(1).Columns.Count <> Area(2).Columns.Count Then
    Err.Raise vbObjectError + 513, Description:="I due intervalli devono essere uguali!"
  End If
  aRng1 = Area(1)
  aRng2 = Area(2)
  Area(1) = aRng2
  Area(2) = aRng1
safety_exit_:
  Set Area = Nothing
  If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical, "errore"
  End If
End Sub
Questa è la versione 'lo-fi' del Forum Per visualizzare la versione completa clicca qui
Tutti gli orari sono GMT+01:00. Adesso sono le 13:44.
Copyright © 2000-2024 FFZ srl - www.freeforumzone.com