Loop through a list of codes in columns and save ones meeting the criteria as their own workbook

[marka87uk]

Hi,

I'd appreciate some help please in doing the following.

I have a spreadsheet set up as follows:

• Column A = question number
• Column B = question text
• Columns C to BFW = a list of 1,528 store numbers in row 1 and their corresponding area codes in row 2

There are approx. 80 different area codes

I need to:

1. Loop through each area code
2. Create a copy of the spreadsheet
3. Delete any columns without the area code currently being looked for in row 2 (ignoring columns A and B)
4. Save each area as its own workbook with the area code as its filename

If you need anymore clarity please let me know!

Thanks in advance.

 

[marka87uk]

I think I've cobbled together a method myself but haven't tested yet (no access to Windows Excel). I've added an extra column with a list of unique areas which is deleted before saving.

Sub SplitByAreasInColumns()Application.ScreenUpdating = False


' Add unique list of area codes into an array
Dim UniqueAreaCodes As Variant
UniqueAreaCodes = Range("A1:A80").Value


' Copy the master worksheet for each unique area code
For Each AreaCode In UniqueAreaCodes
Worksheets("Master").Copy After:=Worksheets("Master")
ActiveSheet.Name = AreaCode
Next


' Go through each worksheet, delete unwanted columns, and save as its own workbook
Dim AreaSheet As Worksheet
For Each AreaSheet In ThisWorkbook.Worksheets
AreaSheet.Activate
    ' Delete columns for other areas
    Set Areas = Range("D1:BFX1")
    For i = Areas.Columns.Count To 1 Step -1
        If ActiveSheet.Name <> "Master" And Areas.Cells(i).Value <> ActiveSheet.Name Then
            Areas.Cells(i).EntireColumn.Delete
        End If
    Next
ActiveSheet.Range("A1").EntireColumn.Delete
' Save worksheet as its own workbook
AreaSheet.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & AreaSheet.Name
ActiveWorkbook.Close SaveChanges:=True
Next AreaSheet


Application.ScreenUpdating = True
End Sub