VBA Separate a single range into multiple ranges

R

ROUKWA

New Member
Joined
Feb 3, 2023
Messages
9
Office Version
  1. 365
Platform
  1. Windows
I appreciate you all in advance.
I want to change the meta range of below code (meta range:M31:AM53) to 42 separated ranges below.
Range("M31:O33,Q31:S33,U31:W33,Y31:AA33,AC31:AE33,AG31:AI33,AK31:AM33,M35:O37,Q35:S37,U35:W37,Y35:AA37,AC35:AE37,AG35:AI37,AK35:AM37,M39:O41,Q39:S41,U39:W41,Y39:AA41,AC39:AE41,AG39:AI41,AK39:AM41,M43:O45,Q43:S45,U43:W45,Y43:AA45,AC43:AE45,AG43:AI45,AK43:AM45,M47:O49,Q47:S49,U47:W49,Y47:AA49,AC47:AE49,AG47:AI49,AK47:AM49,M51:O53,Q51:S53,U51:W53,Y51:AA53,AC51:AE53,AG51:AI53,AK51:AM53")
When I convert the original meta range to that 42 ranges , VBA says "Syntax Error".
I googled and tried addition union methods(? what should i say it?) to the range.
It didn't meet any success, then syntax error happened.
I want to separate a single range into multiple non adjacent ranges.
How Can I handle this?

As the volunteer in charge of scheduling a smartphone workshop for seniors,
I have revised the calendar style schedule to accommodate multiple classes.

To streamline the process, I created a dependent drop-down menu within the calendar.
Each day now has 9 cells to represent the 3 periods of the workshop day.

To simplify inputting the classes, I divided the class names into 3 levels using a dependent drop-down menu,
for example, "Beginner," "Android," "Camera."

I anticipate that using conditional formatting may be challenging, due to huge petterns it should be.
Thus I want to achieve this with VBA.

Any advice and suggestions would be appreciated.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

End Sub
   
    Dim trlRed As Long, oPhoneYellow As Long, adrGreen As Long, iosGrey As Long, cmnPurple As Long
    Dim rng As Range, cell As Range
    
    trlRed = RGB(230, 37, 30)
    oPhoneYellow = RGB(255, 234, 0)
    adrGreen = RGB(61, 220, 132)
    iosGrey = RGB(162, 170, 173)
    cmnPurple = RGB(165, 154, 202)
    
    'firstLvValFor = Array("TRIAL", "BEGINNER", "NOVICE", "INTERMEDIATE", "ADVANCED")
    secondLvValFor = Array("otherPhone", "Android", "iPhone", "Common")
    
    thirdLvValFor_01 = Array("Basic", "Text", "PhoneCall", "mail", "camera", "Browsing", "Apps", "Maps")
    thirLvValFor_02 = Array("Security", "Wi-Fi", "SomeSnsApps_01", "SomeSnsApps_02")
    
    Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
    If Not rng Is Nothing Then
        For Each cell In rng.Cells
            If cell.Value = "Session" And cell.Offset(0, -2).Value = "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
            
            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "otherPhone" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = oPhoneYellow
            
            ElseIf cell.Value = "otherPhone" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = oPhoneYellow
            
            
            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "Android" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = adrGreen
            
            ElseIf cell.Value = "Android" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = adrGreen
                
                
            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "iPhone" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = iosGrey
                
            ElseIf cell.Value = "iPhone" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = iosGrey
            
            
            ElseIf IsError(Application.Match(cell.Value, thirLvValFor_02, 0)) = False And cell.Offset(0, -1).Value = "Common" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = cmnPurple
            
            ElseIf cell.Value = "Common" And IsError(Application.Match(cell.Offset(0, 1).Value, thirLvValFor_02, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = cmnPurple
            

            
            Else
                cell.Interior.ColorIndex = xlColorIndexNone
            End If
        Next cell
    End If
End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Hi,

maybe

VBA Code: 
Public Sub MrE_1229001_1702309()
' https://www.mrexcel.com/board/threads/vba-separate-a-single-range-into-multiple-ranges.1229001/
Dim lngCounter As Long
Dim lngArr As Long
Dim varArr As Variant

Const clngColWide As Long = 3
Const clngRowWide As Long = 3

varArr = Array("M", "Q", "U", "Y", "AC", "AG", "AK")

For lngCounter = 31 To 51 Step 4
  For lngArr = LBound(varArr) To UBound(varArr)
    'putting the results into the Immediate Window here for demonstration
    Debug.Print Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide).Address(0, 0)
  Next lngArr
Next lngCounter
End Sub

Ciao,
Holger
 
Upvote 0
i appreciate your posting.
I don't know how to consolidate your code into this line,
Set rng = Application.Intersect(Target, Me.Range("M31:AM53"))
If Not rng Is Nothing Then
Please tell me further information to this part if you could.
 
Upvote 0
Hi ROUKWA,

maybe like this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
' https://www.mrexcel.com/board/threads/vba-separate-a-single-range-into-multiple-ranges.1229001/
  Dim trlRed As Long, oPhoneYellow As Long, adrGreen As Long, iosGrey As Long, cmnPurple As Long
  Dim rng As Range, cell As Range
  Dim secondLvValFor As Variant
  Dim thirdLvValFor_01 As Variant
  Dim thirLvValFor_02 As Variant
  Dim lngCounter As Long
  Dim lngArr As Long
  Dim lngCol As Long
  Dim varArr As Variant
  Dim rngBig As Range
  
  Const clngColWide As Long = 3
  Const clngRowWide As Long = 3
  
  If Target.Count > 1 Then Exit Sub
  
  trlRed = RGB(230, 37, 30)
  oPhoneYellow = RGB(255, 234, 0)
  adrGreen = RGB(61, 220, 132)
  iosGrey = RGB(162, 170, 173)
  cmnPurple = RGB(165, 154, 202)
  
  'firstLvValFor = Array("TRIAL", "BEGINNER", "NOVICE", "INTERMEDIATE", "ADVANCED")
  secondLvValFor = Array("otherPhone", "Android", "iPhone", "Common")
  
  thirdLvValFor_01 = Array("Basic", "Text", "PhoneCall", "mail", "camera", "Browsing", "Apps", "Maps")
  thirLvValFor_02 = Array("Security", "Wi-Fi", "SomeSnsApps_01", "SomeSnsApps_02")

  varArr = Array("M", "Q", "U", "Y", "AC", "AG", "AK")
  
  For lngCounter = 31 To 51 Step 4
    For lngArr = LBound(varArr) To UBound(varArr)
      If rngBig Is Nothing Then
        Set rngBig = Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide)
      Else
        Set rngBig = Union(rngBig, Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide))
      End If
    Next lngArr
  Next lngCounter
  
  Set rng = Application.Intersect(Target, rngBig)
  If Not rng Is Nothing Then
    For Each cell In rng.Cells
      If cell.Value = "Session" And cell.Offset(0, -2).Value = "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
      
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "otherPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = oPhoneYellow
      
      ElseIf cell.Value = "otherPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = oPhoneYellow
      
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "Android" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = adrGreen
      
      ElseIf cell.Value = "Android" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = adrGreen
        
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "iPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = iosGrey
        
      ElseIf cell.Value = "iPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = iosGrey
      
      ElseIf IsError(Application.Match(cell.Value, thirLvValFor_02, 0)) = False And _
            cell.Offset(0, -1).Value = "Common" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = cmnPurple
      
      ElseIf cell.Value = "Common" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirLvValFor_02, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = cmnPurple
      
      Else
        cell.Interior.ColorIndex = xlColorIndexNone
      End If
    Next cell
  End If
  
end_here:
  Set rng = Nothing
  Set rngBig = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
ROUKWA said:
I want to separate a single range into multiple non adjacent ranges.
How Can I handle this?
Click to expand...


Hi,
try following and see if resolves your issue

VBA Code: 
Sub CombineRanges()

Dim rng(1 To 2) As Range, rngCombine As Range

'Limitation of the substring for Range object is 255 characters.
' to resolve, you divide the ranges in to parts

Set rng(1) = Range("M31:O33,Q31:S33,U31:W33,Y31:AA33,AC31:AE33,AG31:AI33,AK31:AM33,M35:O37,Q35:S37,U35:W37,Y35:AA37," & _
              "AC35:AE37,AG35:AI37,AK35:AM37,M39:O41,Q39:S41,U39:W41,Y39:AA41,AC39:AE41,AG39:AI41,AK39:AM41,M43:O45")
            
Set rng(2) = Range("Q43:S45,U43:W45,Y43:AA45,AC43:AE45,AG43:AI45,AK43:AM45,M47:O49,Q47:S49,U47:W49,Y47:AA49," & _
            "AC47:AE49,AG47:AI49,AK47:AM49,M51:O53,Q51:S53,U51:W53,Y51:AA53,AC51:AE53,AG51:AI53,AK51:AM53")
              
    ' and use Union to combine to single range
    Set rngCombine = Union(rng(1), rng(2))
    
    'you should now have 42 ranges (areas)
    MsgBox rngCombine.Areas.Count
    
End Sub

Dave
 
Upvote 0
HaHoBe said:
Hi ROUKWA,

maybe like this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
' https://www.mrexcel.com/board/threads/vba-separate-a-single-range-into-multiple-ranges.1229001/
  Dim trlRed As Long, oPhoneYellow As Long, adrGreen As Long, iosGrey As Long, cmnPurple As Long
  Dim rng As Range, cell As Range
  Dim secondLvValFor As Variant
  Dim thirdLvValFor_01 As Variant
  Dim thirLvValFor_02 As Variant
  Dim lngCounter As Long
  Dim lngArr As Long
  Dim lngCol As Long
  Dim varArr As Variant
  Dim rngBig As Range
 
  Const clngColWide As Long = 3
  Const clngRowWide As Long = 3
 
  If Target.Count > 1 Then Exit Sub
 
  trlRed = RGB(230, 37, 30)
  oPhoneYellow = RGB(255, 234, 0)
  adrGreen = RGB(61, 220, 132)
  iosGrey = RGB(162, 170, 173)
  cmnPurple = RGB(165, 154, 202)
 
  'firstLvValFor = Array("TRIAL", "BEGINNER", "NOVICE", "INTERMEDIATE", "ADVANCED")
  secondLvValFor = Array("otherPhone", "Android", "iPhone", "Common")
 
  thirdLvValFor_01 = Array("Basic", "Text", "PhoneCall", "mail", "camera", "Browsing", "Apps", "Maps")
  thirLvValFor_02 = Array("Security", "Wi-Fi", "SomeSnsApps_01", "SomeSnsApps_02")

  varArr = Array("M", "Q", "U", "Y", "AC", "AG", "AK")
 
  For lngCounter = 31 To 51 Step 4
    For lngArr = LBound(varArr) To UBound(varArr)
      If rngBig Is Nothing Then
        Set rngBig = Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide)
      Else
        Set rngBig = Union(rngBig, Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide))
      End If
    Next lngArr
  Next lngCounter
 
  Set rng = Application.Intersect(Target, rngBig)
  If Not rng Is Nothing Then
    For Each cell In rng.Cells
      If cell.Value = "Session" And cell.Offset(0, -2).Value = "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
     
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "otherPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = oPhoneYellow
     
      ElseIf cell.Value = "otherPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = oPhoneYellow
     
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "Android" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = adrGreen
     
      ElseIf cell.Value = "Android" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = adrGreen
       
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "iPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = iosGrey
       
      ElseIf cell.Value = "iPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = iosGrey
     
      ElseIf IsError(Application.Match(cell.Value, thirLvValFor_02, 0)) = False And _
            cell.Offset(0, -1).Value = "Common" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = cmnPurple
     
      ElseIf cell.Value = "Common" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirLvValFor_02, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = cmnPurple
     
      Else
        cell.Interior.ColorIndex = xlColorIndexNone
      End If
    Next cell
  End If
 
end_here:
  Set rng = Nothing
  Set rngBig = Nothing
End Sub

Ciao,
Holger
Click to expand...
HaHoBe said:
Hi ROUKWA,

maybe like this:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
' https://www.mrexcel.com/board/threads/vba-separate-a-single-range-into-multiple-ranges.1229001/
  Dim trlRed As Long, oPhoneYellow As Long, adrGreen As Long, iosGrey As Long, cmnPurple As Long
  Dim rng As Range, cell As Range
  Dim secondLvValFor As Variant
  Dim thirdLvValFor_01 As Variant
  Dim thirLvValFor_02 As Variant
  Dim lngCounter As Long
  Dim lngArr As Long
  Dim lngCol As Long
  Dim varArr As Variant
  Dim rngBig As Range
 
  Const clngColWide As Long = 3
  Const clngRowWide As Long = 3
 
  If Target.Count > 1 Then Exit Sub
 
  trlRed = RGB(230, 37, 30)
  oPhoneYellow = RGB(255, 234, 0)
  adrGreen = RGB(61, 220, 132)
  iosGrey = RGB(162, 170, 173)
  cmnPurple = RGB(165, 154, 202)
 
  'firstLvValFor = Array("TRIAL", "BEGINNER", "NOVICE", "INTERMEDIATE", "ADVANCED")
  secondLvValFor = Array("otherPhone", "Android", "iPhone", "Common")
 
  thirdLvValFor_01 = Array("Basic", "Text", "PhoneCall", "mail", "camera", "Browsing", "Apps", "Maps")
  thirLvValFor_02 = Array("Security", "Wi-Fi", "SomeSnsApps_01", "SomeSnsApps_02")

  varArr = Array("M", "Q", "U", "Y", "AC", "AG", "AK")
 
  For lngCounter = 31 To 51 Step 4
    For lngArr = LBound(varArr) To UBound(varArr)
      If rngBig Is Nothing Then
        Set rngBig = Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide)
      Else
        Set rngBig = Union(rngBig, Cells(lngCounter, varArr(lngArr)).Resize(clngRowWide, clngColWide))
      End If
    Next lngArr
  Next lngCounter
 
  Set rng = Application.Intersect(Target, rngBig)
  If Not rng Is Nothing Then
    For Each cell In rng.Cells
      If cell.Value = "Session" And cell.Offset(0, -2).Value = "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed
     
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "otherPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = oPhoneYellow
     
      ElseIf cell.Value = "otherPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = oPhoneYellow
     
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "Android" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = adrGreen
     
      ElseIf cell.Value = "Android" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = adrGreen
       
      ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And _
            cell.Offset(0, -1).Value = "iPhone" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = iosGrey
       
      ElseIf cell.Value = "iPhone" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = iosGrey
     
      ElseIf IsError(Application.Match(cell.Value, thirLvValFor_02, 0)) = False And _
            cell.Offset(0, -1).Value = "Common" And _
            cell.Offset(0, -2).Value <> "TRIAL" Then
        cell.Offset(0, -2).Resize(1, 3).Interior.Color = cmnPurple
     
      ElseIf cell.Value = "Common" And _
            IsError(Application.Match(cell.Offset(0, 1).Value, thirLvValFor_02, 0)) = False _
            And cell.Offset(0, -1).Value <> "TRIAL" Then
        cell.Offset(0, -1).Resize(1, 3).Interior.Color = cmnPurple
     
      Else
        cell.Interior.ColorIndex = xlColorIndexNone
      End If
    Next cell
  End If
 
end_here:
  Set rng = Nothing
  Set rngBig = Nothing
End Sub

Ciao,
Holger
Click to expand...
I appreciate you sincerely Holger san. Thankfully this code works.
However, Original code can handle entering and deleting values to multiple cells.
e.g. I often use ctrl + enter inputting, when whole day is same classes. 1,2,3, periods camera classes(workshop).
Can I modify this code to be able handle entering & deleting values to multiple cells?
If you have any idea related this issue. Please teach me.
Thank you.
 
Upvote 0
dmt32 said:
Hi,
try following and see if resolves your issue

VBA Code: 
Sub CombineRanges()

Dim rng(1 To 2) As Range, rngCombine As Range

'Limitation of the substring for Range object is 255 characters.
' to resolve, you divide the ranges in to parts

Set rng(1) = Range("M31:O33,Q31:S33,U31:W33,Y31:AA33,AC31:AE33,AG31:AI33,AK31:AM33,M35:O37,Q35:S37,U35:W37,Y35:AA37," & _
              "AC35:AE37,AG35:AI37,AK35:AM37,M39:O41,Q39:S41,U39:W41,Y39:AA41,AC39:AE41,AG39:AI41,AK39:AM41,M43:O45")
           
Set rng(2) = Range("Q43:S45,U43:W45,Y43:AA45,AC43:AE45,AG43:AI45,AK43:AM45,M47:O49,Q47:S49,U47:W49,Y47:AA49," & _
            "AC47:AE49,AG47:AI49,AK47:AM49,M51:O53,Q51:S53,U51:W53,Y51:AA53,AC51:AE53,AG51:AI53,AK51:AM53")
             
    ' and use Union to combine to single range
    Set rngCombine = Union(rng(1), rng(2))
   
    'you should now have 42 ranges (areas)
    MsgBox rngCombine.Areas.Count
   
End Sub

Dave
Click to expand...
I appreciate your suggestion. I will try your code later.　Thank you for everything.
 
Upvote 0
Hi ROUKWA,

just change

VBA Code: 
  If Target.Count > 1 Then Exit Sub

which limits the target to be just one cell either by deleting this codeline or by commenting it like

VBA Code: 
'  If Target.Count > 1 Then Exit Sub

Ciao,
Holger
 
Upvote 0
HaHoBe said:
Hi ROUKWA,

just change

VBA Code: 
  If Target.Count > 1 Then Exit Sub

which limits the target to be just one cell either by deleting this codeline or by commenting it like

VBA Code: 
'  If Target.Count > 1 Then Exit Sub

Ciao,
Holger
Click to expand...
 
Upvote 0
Hello, Holger san.
WOW! It works, when I entering values to multiple cells, then multiple cells turn into certain colors.
But, Why? If you have some time, it'd be great to teach me explaination of your code step by step.
Also if you could please tell me what kind of materials and texts did you use to learn VBA?

Thank you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
VBA , To consolidate two worksheet_chang events or to add events to another one
Replies
0
Views
497
ROUKWA
R
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
258
tixarah
T
S
  • Question Question
VBA lookup by taking common column from user
Replies
2
Views
190
StephenCrump
S
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
885
Legacy 352679
L
D
  • Solved
TextBox looping help required in VBA
Replies
3
Views
509
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,157
Messages
6,170,419
Members
452,325
Latest member
BlahQz

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top