Excel VBA – Copy Range into Array

In many of my VBA projects, I need to loop through a range of cells and break up a large dataset into smaller datasets, typically moving the subsets of data to their own worksheets.  Many times, the range of data I need to loop through is the distinct list of items in a particular column.  In this post, I will demonstrate how to create a unique list of items for a given column, then copy the range into an Array for further action and processing.

Excel VBA – Copy Range into Array – Setup

Here is the macro code:

Let’s say you have the following table.  I encourage you to copy the contents into a new Excel workbook, and step through the code above:

WeekTeamOpp
1BUFIND
1MIA@WAS
1NEPIT
1NYJCLE
2BUFNE
2MIA@JAC
2NE@BUF
2NYJ@IND
3BUF@MIA
3MIABUF
3NEJAC
3NYJPHI
4BUFNYG
4MIANYJ
4NEBYE
4NYJ@MIA

 

When executing the code above, the macro will first sort the table by column B and filter column B for unique values, copying the results into column D.

Code:

Excel VBA - Copy Range into Array

Results in the unique values of column B being copied into column D:

Excel VBA - Copy Range into Array

From there, the next block of code actually creates the Array:

Excel VBA - Copy Range into Array

Lastly, the code for looping through the Array values:

Excel VBA - Copy Range into Array

presents each value in a Message Box:

Excel VBA - Copy Range into Array

This comes in handy when you are trying to loop through unique values in a given column, which allows further action based on these unique values.  I often use this code when I need to take a table and create new worksheets based on the unique value of a specific column.

You can modify this macro to meet your needs.

 

Additional Content

Check out more examples by visiting my Home Page

Here you will find topics covering  Qlikview  SQL Server  Excel VBA

8 thoughts on “Excel VBA – Copy Range into Array”

  1. Hello bbiadmin,really great job.
    It’s working perfectly fine and I modified the rows according to my requirements. Thanks a lot! But,there’s a problem in my excel file i.e there’s a column contains the date format(dd-mmm-yy) and when i applying this macro and the resultant file converted into normal text type. Is there’s any way to maintain the same format as source file (dd-mmm-yy). Help in this regard is highly appreciated.

  2. Great Job admin,it’s successfully creating the excel file but there’s no data only showing the header. Plea help out.

    • It likely has to do with the filter. Play around with the following in the macro, and just make sure it is doing the filter on the column that is being copied into the Array (i.e. “Field:=2” in bolded line. Just need to make sure this is the right column that is getting the Array values):

      With ActiveSheet
      	.AutoFilterMode = False
      	.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:="=" & Arr(R, C)
      	.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
      	.AutoFilterMode = False
      End With
      < \pre>
      • I had to update macro to properly save to same folder as source file, see below (changes in bold):

        Option Explicit
         
        Sub CreateArray()
        
        Range("A1").Select
        
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        
        Dim ws As Worksheet
        Set ws = ActiveWorkbook.ActiveSheet
        
        Range("A1").CurrentRegion.Select
        
        Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
        Range("A1").Select
        
        ActiveSheet.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=ActiveCell.End(xlToRight).Offset(0, 1), Unique:=True
        
        ActiveCell.End(xlToRight).Offset(1, 0).Select
        
        Dim Arr() As Variant
        Arr = Range(ActiveCell, ActiveCell.End(xlDown))
        
        ActiveCell.EntireColumn.Delete
        Range("A1").Select
        
        Dim R As Long
        Dim C As Long
        
        For R = 1 To UBound(Arr, 1) ' Row
            For C = 1 To UBound(Arr, 2) ' Column
        
                        With ActiveSheet
                            .AutoFilterMode = False
                            .Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:="=" & Arr(R, C)
                            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
                            .AutoFilterMode = False
                        End With
                        
                        Workbooks.Add
                        ActiveCell.PasteSpecial (xlPasteValues)
                        Application.CutCopyMode = False
                        ActiveWorkbook.SaveAs Filename:=wb.Path & "\" & Arr(R, C) & ".xlsx"
                        ActiveWorkbook.Close
                        
            Next C
        Next R
        
        Range("A1").Select
        
        End Sub
        
  3. Hello bbiadmin,

    I have an excel file of employee details. I want to create a separate excel file for each employee consists data of that particular employee only.
    How can I achieve that. Please help.

    • I modified the macro code below. Please give it a try. It will create a new workbook for each unique value of Array, and past content into new workbook based on filtered content of Array value. It will then save the new workbook in the same path as the source file.

      
      Option Explicit
       
      Sub CreateArray()
      
      Range("A1").Select
      
      Dim ws As Worksheet
      Set ws = ActiveWorkbook.ActiveSheet
      
      Range("A1").CurrentRegion.Select
      
      Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
      
      Range("A1").Select
      
      ActiveSheet.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, _
              CopyToRange:=ActiveCell.End(xlToRight).Offset(0, 1), Unique:=True
      
      ActiveCell.End(xlToRight).Offset(1, 0).Select
      
      Dim Arr() As Variant
      Arr = Range(ActiveCell, ActiveCell.End(xlDown))
      
      ActiveCell.EntireColumn.Delete
      Range("A1").Select
      
      Dim R As Long
      Dim C As Long
      
      For R = 1 To UBound(Arr, 1) ' Row
          For C = 1 To UBound(Arr, 2) ' Column
      
                      With ActiveSheet
                          .AutoFilterMode = False
                          .Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:="=" & Arr(R, C)
                          .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
                          .AutoFilterMode = False
                      End With
                      
                      Workbooks.Add
                      ActiveCell.PasteSpecial (xlPasteValues)
                      Application.CutCopyMode = False
                      ActiveWorkbook.SaveAs Filename:=Arr(R, C) & ".xlsx"
                      ActiveWorkbook.Close
                      
          Next C
      Next R
      
      Range("A1").Select
      
      End Sub
      
      < \pre>

Leave a Comment