Add Range/s to Array Based on CheckBox value being True

[Andyw111]

Hi All,

I hope so one can help me, I have a UserForm with 9 Checkboxes (1 to9) and each Checkbox relates to a specific range of cells from 9 separate worksheets.

I have set the ranges to Rng1 to Rng9

I want to add only the ranges (Rng1 to Rng9) that have been checked as true to an array called RngArray.

Is there any easy way to loop through the checkboxes and only add those that have been checked to the array?

Many thanks in advance.

Andy

 

[Andyw111]

Cross posted Add Range/s to Array Based on CheckBox value being True

While we do allow Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered elsewhere.

Apologies I wasn't aware of this, the help from the members of this forum has been much better and helpful.

Andy

 

[Andyw111]

In taking a quick look, I see a couple of issues...

1) you've declared ExcRng twice, so you should be getting an error telling you that you have a duplicate declaration. So remove the second declaration from your code.

2) you're assigning RngArray to ExcRng, whereas you should be assigning Rngr instead...

Set ExcRng = Rngr

I would also suggest placing the following statement at the very top of your module before any code...

Option Explicit

This forces the explicit declaration of variables and will help catch some errors.

Hi again I have now got it working with the code below, however its pasting the order last to first rather than first to last. Is there away to transpose is it paste in the correct order?

Private Sub CommandButton1_Click()

    Dim WrdApp As Word.Application
    Dim WrdDoc As Word.Document
    Dim ExcRng As Range
    Dim Rng As Variant
    
    Dim Rng1 As Range
    Dim Rng2 As Range
    Dim Rng3 As Range
    Dim Rng4 As Range
    Dim Rng5 As Range
    Dim Rng6 As Range
    Dim Rng7 As Range
    Dim Rng8 As Range
    Dim Rng9 As Range
    
      
    Set Rng1 = Sheet21.Range("B1:F7")  'Checkbox 1
    Set Rng2 = Sheet21.Range("B8:F38") 'Checkbox 2
    Set Rng3 = Sheet5.Range("B8:F30")  'Checkbox 3
    Set Rng4 = Sheet6.Range("B8:F62")  'Checkbox 4
    Set Rng5 = Sheet7.Range("B8:F50")  'Checkbox 5
    Set Rng6 = Sheet8.Range("B8:F56")  'Checkbox 6
    Set Rng7 = Sheet9.Range("B8:F98")  'Checkbox 7
    Set Rng8 = Sheet10.Range("B8:F56") 'Checkbox 8
    Set Rng9 = Sheet11.Range("B8:F44") 'Checkbox 9
    
      
  Dim AllRanges As Variant
    AllRanges = Array(Rng1, Rng2, Rng3, Rng4, Rng5, Rng6, Rng7, Rng8, Rng9)
    
    
  
    ReDim RngArray(UBound(AllRanges)) As Range
  
    Dim Count As Long
    Count = 0
  
    Dim i As Long
    For i = LBound(AllRanges) To UBound(AllRanges)
        If Me.Controls("CheckBox" & i + 1).Value = True Then
            Set RngArray(Count) = AllRanges(i)
            Count = Count + 1
        
                
        End If
    Next i
  
    If Count > 0 Then
        ReDim Preserve RngArray(Count)
 

 
  Set WrdApp = New Word.Application
    WrdApp.Visible = True
    WrdApp.Activate
    

Set WrdDoc = WrdApp.Documents.Add

Dim Count1 As Long
Count1 = 0

For Each Rng In RngArray

   Set ExcRng = Rng
       ExcRng.Copy
      
 
   With WrdApp.Selection
        .Range.Paste
        
   Count1 = Count1 + 1
  
 
  
    End With
    
    If Count1 = Count Then
    Exit For
    End If
    
  
   Next
  
 

  Set WordTable = WrdDoc.Tables(1)
           WordTable.AutoFitBehavior (wdAutoFitWindow)
          

          
    Else
        MsgBox "No checkboxes selected!", vbExclamation
    End If
    
End Sub

Many thanks

Andy

 

[Andyw111]

I've cracked it, I hadn't matched the CheckBox1 to 9 numbers with the Rng1 to 9 number. I've corrected this and now it works perfectly.

Many thanks to Domenic for your help with this.

The final code is:

Private Sub CommandButton1_Click()

    
    Dim WrdApp As Word.Application
    Dim WrdDoc As Word.Document
    Dim ExcRng As Range
    Dim Rng As Variant
    
    Dim Rng1 As Range
    Dim Rng2 As Range
    Dim Rng3 As Range
    Dim Rng4 As Range
    Dim Rng5 As Range
    Dim Rng6 As Range
    Dim Rng7 As Range
    Dim Rng8 As Range
    Dim Rng9 As Range
    
      
    Set Rng1 = Sheet11.Range("B8:F44")  'Checkbox 1
    Set Rng2 = Sheet10.Range("B8:F56") 'Checkbox 2
    Set Rng3 = Sheet9.Range("B8:F98")  'Checkbox 3
    Set Rng4 = Sheet8.Range("B8:F56")  'Checkbox 4
    Set Rng5 = Sheet7.Range("B8:F50")  'Checkbox 5
    Set Rng6 = Sheet6.Range("B8:F62")  'Checkbox 6
    Set Rng7 = Sheet5.Range("B8:F30")  'Checkbox 7
    Set Rng8 = Sheet21.Range("B8:F38") 'Checkbox 8
    Set Rng9 = Sheet21.Range("B1:F7") 'Checkbox 9
      
    
      
  Dim AllRanges As Variant
    AllRanges = Array(Rng1, Rng2, Rng3, Rng4, Rng5, Rng6, Rng7, Rng8, Rng9)
    
    
  
    ReDim RngArray(UBound(AllRanges)) As Range
  
    Dim Count As Long
    Count = 0
  
    Dim i As Long
    For i = LBound(AllRanges) To UBound(AllRanges)
        If Me.Controls("CheckBox" & i + 1).Value = True Then
            Set RngArray(Count) = AllRanges(i)
            Count = Count + 1
        
                
        End If
    Next i
  
    If Count > 0 Then
        ReDim Preserve RngArray(Count)
 

 
  Set WrdApp = New Word.Application
    WrdApp.Visible = True
    WrdApp.Activate
    

Set WrdDoc = WrdApp.Documents.Add

Dim Count1 As Long
Count1 = 0

For Each Rng In RngArray

   Set ExcRng = Rng
       ExcRng.Copy
      
 
   With WrdApp.Selection
        .Range.Paste
        
   Count1 = Count1 + 1
  
 
  
    End With
    
    If Count1 = Count Then
    Exit For
    End If
    
  
   Next
  
 

  Set WordTable = WrdDoc.Tables(1)
           WordTable.AutoFitBehavior (wdAutoFitWindow)
          

          
    Else
        MsgBox "No checkboxes selected!", vbExclamation
    End If
    
    Unload Me
    
End Sub

Andy

 

[Domenic]

That's great, glad you've sorted it out.

Cheers!