Punte di Excel
  1. Punte di Excel
  3. Impedire agli utenti di eliminare una row in una particolare tabella con un certo valore in una particolare colonna in Excel
Intereting Posts
Esportre il foglio di Google come xlsx all'unità di networking aziendale Excel VBA help – eseguire una serie di regex trovare e sostituisce Come scrivere il codice VBA per aggiungere la firma digitale per proteggere VBAProject? È necessario creare un count in esecuzione (a partire da 1) in base a date e nomi (utilizzando un loop?) Prodotto di sum con due condizioni e due matrici Fare un collegamento forzato tra il rifornimento aperto per aprire i lavori Come utilizzare JExcel WritableFont in ColdFusion VSTO – Imansible distribuire un'applicazione Trova e Lineari interpolare dati mancanti in Excel MIN IF Funzione in VBA Controllare se un file pdf è aperto e chiuderlo VBA macro per inserire row dopo il text trovato Comprensione delle liste di uncool Lettura di each row di un file di text in VB Lettura della casella Modifica di Excel

Impedire agli utenti di eliminare una row in una particolare tabella con un certo valore in una particolare colonna in Excel

Questo può essere simile a questa domanda, ma ritengo che passi un ulteriore passo avanti nella complessità per cui ho chiesto.

Context: Sto costruendo un foglio di calcolo di bilancio che può creare e eliminare righe dalle tabelle. Nel foglio ho due tavoli. Uno contiene totali in base alla categoria, mentre l'altra tabella contiene le transactions che l'utente può entrare per popolare i totali nell'altra tabella. Ho protetto il foglio di lavoro per impedire agli utenti di rompere le formule e solo avere le celle da modificare (cioè i valori di input in) non protetti. Ho anche delle macro per inserire e cancellare una o più righe in una tabella (ho codificato le macro per non proteggere / proteggere il foglio di lavoro prima e dopo che la macro è terminata).

Problema: la mia domanda riguarda il primo tavolo . In quella tabella desidero assicurarsi che la row "Depositi" non possa essere eliminata. La domanda è nel mio codice come posso garantire che l'utente possa eliminare tutte le altre righe in un'altra tabella che contiene "Depositi" evitando la cancellazione della row "Depositi" in questa tabella? Penso al seguente codice pseudo, ma ritengo libero di fare altri suggerimenti: 

'If selected range contains cells in Column A 'and cell in selected range = Deposits 'Then pop error message 'Exit Sub

Ecco il codice che ho per la mia macro di cancellazione 

 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Dim c As Range Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Per each c In Selection.Cells Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub iCnt = iCnt + 1 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Su errore riprendere successivo Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub iCnt = iCnt + 1 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Errore GoTo 0 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Avanti c Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Uscire da Sub Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Next iCnt Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Uscire da Sub Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub End Sub Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub Dim vTemp come variante Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Sub SortArray(MyArray() As Variant) Dim iStart As Long Dim iEnd As Long Dim iStep As Long Dim iMove As Long Dim vTemp As Variant iStart = LBound(MyArray) iEnd = UBound(MyArray) For iStep = iStart To iEnd - 1 For iMove = iStep + 1 To iEnd If MyArray(iStep) > MyArray(iMove) Then vTemp = MyArray(iMove) MyArray(iMove) = MyArray(iStep) MyArray(iStep) = vTemp End If Next iMove Next iStep End Sub

A proposito, non sono venuto in mente tutto questo; Ho tagliato la maggior parte di questo codice. 🙂 Fammi sapere se hai bisogno di ulteriori informazioni o context. Grazie in anticipo!

Ecco il link alla cartella di lavoro di bilancio.

Se ActiveSheet.Cells (c.Row, 1) .Value = "Depositi" ThenHere è il sottogruppo DeleteRow che lavora 

 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Dim c As Range Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Per each c In Selection.Cells Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub & vbCrLf & _ Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Per each c In Selection.Cells Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub iCnt = iCnt + 1 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Su errore riprendere successivo Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub iCnt = iCnt + 1 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Errore GoTo 0 Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Avanti c Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Uscire da Sub Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Next iCnt Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub Uscire da Sub Sub DeleteRow() ' ' DeleteRow Macro ' ' Keyboard Shortcut: Ctrl+Shift+D ' Dim loTtest As ListObject Dim loSet As ListObject Dim c As Range Dim arrRows() As Variant Dim arrTemp() As Variant Dim xFind As Variant Dim iCnt As Long Dim sMsg As String ActiveSheet.Unprotect Password:="PYS" Erase arrRows() iCnt = 1 'This is the loop that I added before anything else to keep people from deleting the row with "Deposits" For Each c In Selection.Cells If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _ "The 'Deposits' row cannot be deleted!", vbExclamation GoTo MyExit End If Next For Each c In Selection.Cells If Not c.ListObject Is Nothing Then If loSet Is Nothing Then Set loSet = c.ListObject Else If c.ListObject <> loSet Then 'different table MsgBox "You have more than one table selected.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If End If If iCnt = 1 Then ReDim arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 Else On Error Resume Next xFind = 0 xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0) If xFind = 0 Then ReDim Preserve arrRows(1 To iCnt) arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row iCnt = iCnt + 1 End If Err.Clear On Error GoTo 0 End If Else 'a cell is not in a table MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!" ActiveSheet.Protect Password:="PYS" GoTo MyExit End If Next c Call SortArray(arrRows()) sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?" If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then ActiveSheet.Protect Password:="PYS" Exit Sub End If For iCnt = UBound(arrRows) To LBound(arrRows) Step -1 loSet.ListRows(arrRows(iCnt)).Delete Next iCnt ActiveSheet.Protect Password:="PYS" Exit Sub MyExit: End Sub