How to disable multi row/column selection in inputbox?

Question

I am looking for a way to disable multi selection in my inputbox if the user selects multiple rows and columns at the same time. I have tried this code:

Dim rng As Range
Set rng = Application.InputBox("dasdasd", "asdas", "", Type:=8)

If rng.Columns.Count > 1 And rng.Rows.Count > 1 Then
    MsgBox "Multiple selection allowed only within the same row or column"
    Exit Sub
Else
    'carry on
End If

What I want to do is to disable multi-column and multi-row selection at the same time. For example - if I select (using ctrl key) range "D1:D5","D8:D10" then it is correct, as this is multiple row selection BUT within ONE column. If I select "D1:D5","E8:E10" then it should pop error, msgbox, whatever. If only one row or column are selected then it should keep going in procedure. If multiple rows AND multiple columns have been selected then it should exit sub.

The code above always returns one row or one column, no matter how many ranges I select across many rows/columns. I have tried current region approach, but this selects entire region, even the thing I have not selected...

I will be grateful for help.

Answer 1

You can loop through the areas and keep a tally of the rows and columns covered by the selection. Using two dictionaries seems like overkill, but it seems to do the job.

If your range consists of several non-contiguous areas your code will only consider the first block, e.g. D1:D5

Sub x()

Dim oDicR As Object, oDicC As Object, rArea As Range, rCell As Range, rng As Range

Set oDicR = CreateObject("Scripting.Dictionary")
Set oDicC = CreateObject("Scripting.Dictionary")
Set rng = Application.InputBox("dasdasd", "asdas", "", Type:=8)

For Each rArea In rng.Areas
    For Each rCell In rArea
        oDicR(rCell.Row) = 1
        oDicC(rCell.Column) = 1
    Next rCell
    If oDicR.Count > 1 And oDicC.Count > 1 Then
        MsgBox "Multiple selection allowed only within the same row or column"
        Exit Sub
    End If
Next rArea

'do whatever

End Sub

Answer 2

Sub test()

Dim rng As Range, cl As Range, allRng As Range
Dim minRw As Long, minCl As Long, maxRw As Long, maxCl As Long

On Error Resume Next
Set rng = Application.InputBox("dasdasd", "asdas", "", Type:=8)
If rng Is Nothing Then
    MsgBox "You have not selected any range"
    Exit Sub
End If    
Err.Clear
On Error GoTo 0

minRw = rng.Cells(1, 1).Row
minCl = rng.Cells(1, 1).Column

For Each cl In rng
    If cl.Row < minRw Then minRw = cl.Row Else: If cl.Row > maxRw Then maxRw = cl.Row
    If cl.Column < minCl Then minCl = cl.Column Else: If cl.Column > maxCl Then maxCl = cl.Column
Next
Set allRng = Range(Cells(minRw, minCl), Cells(maxRw, maxCl))

If allRng.Rows.Count > 1 And allRng.Columns.Count > 1 Then
    MsgBox "Multiple selection allowed only within the same row or column"
    Exit Sub
End If

End Sub