Automate Data Management in Excel with VBA: A Comprehensive Guide

Managing data in Excel can be a tedious task, especially when dealing with large datasets and repetitive tasks. VBA (Visual Basic for Applications) offers a powerful solution to automate these processes, saving time and reducing errors. In this blog post, we'll walk you through two essential VBA scripts: one for saving data into separate files based on unique values and another for filtering and copying data based on criteria from another sheet.

Script 1: Save Data into Separate Files

This script saves rows of data into separate files based on unique values in a specified column. Each file is named according to the unique value and the current date.

The VBA Script

Sub SaveSeparateFiles()
    Dim ws As Worksheet
    Dim uniqueROs As Collection
    Dim cell As Range
    Dim ro As Variant
    Dim roData As Range
    Dim roSheet As Worksheet
    Dim filePath As String
    Dim savePath As String
    Dim currentDate As String
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Get the save path from cell C1
    savePath = ws.Range("C1").Value
    
    ' Check if the save path exists
    If Dir(savePath, vbDirectory) = "" Then
        MsgBox "The directory specified in C1 does not exist.", vbCritical
        Exit Sub
    End If
    
    ' Get the current date
    currentDate = Format(Date, "yyyy-mm-dd")
    
    ' Create a collection to store unique RO values
    Set uniqueROs = New Collection
    
    ' Loop through the RO #1 column and add unique values to the collection
    On Error Resume Next
    For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        uniqueROs.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0
    
    ' Loop through the unique RO values and create separate files
    For Each ro In uniqueROs
        ' Filter the data for the current RO
        ws.Range("A1").AutoFilter Field:=1, Criteria1:=ro
        
        ' Copy the filtered data to a new worksheet
        Set roSheet = Worksheets.Add
        ws.Range("A2").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=roSheet.Range("A1")
        roSheet.Name = "TempSheet"
        
        ' Delete the first row of the new worksheet
        roSheet.Rows(1).Delete
        
        ' Save the new worksheet as a separate file
        filePath = savePath & "\RO" & ro & "_" & currentDate & ".xlsx"
        roSheet.Move
        ActiveWorkbook.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close SaveChanges:=False
        
        ' Return to the original workbook
        Set roSheet = Nothing
        
        ' Check if "TempSheet" exists and delete it if it does
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets("TempSheet").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
    Next ro
    
    ' Remove the filter from the original worksheet
    ws.AutoFilterMode = False
    
    MsgBox "Files have been saved successfully.", vbInformation
End Sub

How It Works

1. Initialize the Worksheet: Set the worksheet and get the save path from cell C1.

   Set ws = ThisWorkbook.Sheets("Sheet1")
   savePath = ws.Range("C1").Value

2. Check the Save Path: Ensure the directory specified in C1 exists.

   If Dir(savePath, vbDirectory) = "" Then
       MsgBox "The directory specified in C1 does not exist.", vbCritical
       Exit Sub
   End If

3. Create a Collection of Unique Values: Loop through the column and add unique values to the collection.

   Set uniqueROs = New Collection
   On Error Resume Next
   For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
       uniqueROs.Add cell.Value, CStr(cell.Value)
   Next cell
   On Error GoTo 0

4. Filter and Save Data: For each unique value, filter the data, copy it to a new worksheet, and save it as a separate file.

   For Each ro In uniqueROs
       ' Filter the data for the current RO
       ws.Range("A1").AutoFilter Field:=1, Criteria1:=ro
       
       ' Copy the filtered data to a new worksheet
       Set roSheet = Worksheets.Add
       ws.Range("A2").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=roSheet.Range("A1")
       roSheet.Name = "TempSheet"
       
       ' Delete the first row of the new worksheet
       roSheet.Rows(1).Delete
       
       ' Save the new worksheet as a separate file
       filePath = savePath & "\RO" & ro & "_" & currentDate & ".xlsx"
       roSheet.Move
       ActiveWorkbook.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
       ActiveWorkbook.Close SaveChanges:=False
       
       ' Return to the original workbook
       Set roSheet = Nothing
       
       ' Check if "TempSheet" exists and delete it if it does
       On Error Resume Next
       Application.DisplayAlerts = False
       ThisWorkbook.Sheets("TempSheet").Delete
       Application.DisplayAlerts = True
       On Error GoTo 0
   Next ro

5. Remove Filter: Remove the filter from the original worksheet.

   ws.AutoFilterMode = False

Script 2: Filter and Copy Data

This script filters data in one sheet based on criteria from another sheet and copies the filtered data to a new sheet.

The VBA Script

Sub FilterAndCopy()
    Dim ws1 As Worksheet, ws2 As Worksheet, wsNew As Worksheet
    Dim filterValues As Range
    Dim lastRow As Long, lastFilterRow As Long
    Dim filterRange As Range
    Dim cell As Range
    Dim firstCopy As Boolean
    
    ' Initialize the firstCopy flag
    firstCopy = True

    ' Set references to the worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Find the last row in Sheet2 to determine the range of filter values
    lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    Set filterValues = ws2.Range("A2:A" & lastRow)
    
    ' Add a new worksheet for the filtered data
    Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "Filtered Data"
    
    ' Copy the header from Sheet1 to the new sheet
    ws1.Rows(1).Copy Destination:=wsNew.Rows(1)
    
    ' Find the last row in Sheet1 to determine the range for filtering
    lastFilterRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    Set filterRange = ws1.Range("A1").CurrentRegion
    
    ' Apply the filter
    For Each cell In filterValues
        If Application.WorksheetFunction.CountIf(ws1.Range("A2:A" & lastFilterRow), cell.Value) > 0 Then
            ws1.Range("A1").AutoFilter Field:=1,

 Criteria1:=cell.Value
            If firstCopy Then
                ws1.Range("A2:A" & lastFilterRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                    Destination:=wsNew.Cells(2, 1)
                firstCopy = False
            Else
                ws1.Range("A2:A" & lastFilterRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                    Destination:=wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End If
    Next cell
    
    ' Turn off the filter
    ws1.AutoFilterMode = False
End Sub

How It Works

1. Initialize the Worksheets: Set references to the worksheets and determine the range of filter values.

   Set ws1 = ThisWorkbook.Sheets("Sheet1")
   Set ws2 = ThisWorkbook.Sheets("Sheet2")
   lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   Set filterValues = ws2.Range("A2:A" & lastRow)

2. Create a New Worksheet: Add a new worksheet for the filtered data and copy the header from Sheet1.

   Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
   wsNew.Name = "Filtered Data"
   ws1.Rows(1).Copy Destination:=wsNew.Rows(1)

3. Apply the Filter: Loop through the filter values, apply the filter to Sheet1, and copy the visible rows to the new worksheet.

   For Each cell In filterValues
       If Application.WorksheetFunction.CountIf(ws1.Range("A2:A" & lastFilterRow), cell.Value) > 0 Then
           ws1.Range("A1").AutoFilter Field:=1, Criteria1:=cell.Value
           If firstCopy Then
               ws1.Range("A2:A" & lastFilterRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                   Destination:=wsNew.Cells(2, 1)
               firstCopy = False
           Else
               ws1.Range("A2:A" & lastFilterRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                   Destination:=wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Offset(1, 0)
           End If
       End If
   Next cell

4. Turn Off the Filter: Turn off the filter in the original worksheet.

   ws1.AutoFilterMode = False

Conclusion

These VBA scripts can significantly streamline your data management tasks in Excel. By automating the process of saving data into separate files and filtering and copying data based on criteria from another sheet, you can save time and reduce the risk of errors. Customize these scripts to fit your specific needs and enhance your productivity.

Feel free to share your thoughts and improvements in the comments below. Happy coding!

```