How To Segregate Data by Region and Export Each Region Data to a New Work Book using Excel VBA Macro

Excel VBA Macro To Segregate Data by Region and Export To New Work Books

'Example :- Suppose there is a Workbook Called "MyBook" in which there is a sheet called "MyData" .

'The sheet "MyData" contains data of Different Regions with respective Countries , Products, Sales.

'Let us consider all Regions are Mentioned In the First Column of a sheet,then

'The Following Macro Exports All Data of each Region to New Workbook by the Current Region Name.

Sub ExportSegData()

Dim X As Integer

Dim Y As Integer

Dim Z As Integer

Dim A As Integer

Dim C As Integer

Dim D As Integer

Dim F As String

Dim P As String

Dim B As String

Dim I As String

Dim J As String

Dim S As String

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Application.Visible = False

On Error Resume Next

Z = 0

D = 0

P = "C:\Documents and Settings\Administrator\My Documents\" 'Export To This Path

I = InputBox("Enter Current WorkBook Name  ", "Workbook From Which Data To Be Segregate", "Enter Here...")

'Current WorkBook Name From Which Data To Be Segregate

J = InputBox("Enter Data Sheet Name In Current WorkBook ", "Worksheet From Which Data To Be Segregate", "Enter Here...")

'Current Data Sheet Name From Which Data To Be Segregate

F = Workbooks(I).Name

B = Workbooks(I).Sheets(J).Name

MkDir P & F

For X = 2 To 1000

If Workbooks(I).Sheets(J).Cells(X, 1) = "" Then Exit For

If Workbooks(I).Sheets(J).Cells(X, 1) <> Workbooks(I).Sheets(J).Cells(X + 1, 1) Then

S = Workbooks(I).Sheets(J).Cells(X, 1)

Workbooks.ADD.SaveAs (P & F & "\" & S & ".xlsx")

'Adds A New Workbook To Export Data

Workbooks(S).Sheets(1).Name = S

For A = 1 To 26    'Columns Having The Data

For Y = 2 To 100  'Rows Having The Data

If InStr(LCase(Workbooks(I).Sheets(J).Cells(Y, 1)), LCase(S)) Then

Z = Z + 1

ActiveWorkbook.Sheets(S).Cells(Z, A) = Workbooks(I).Sheets(J).Cells(Y, A)

ActiveWorkbook.Sheets(S).Cells(1, A) = Workbooks(I).Sheets(J).Cells(1, A)

ActiveWorkbook.Sheets(S).Cells(1, A).Font.Bold = True

End If

Next Y

Z = 1

Next A

For C = 2 To 100

If ActiveWorkbook.Sheets(S).Cells(C, 4) <> "" Then

D = D + 1

ActiveWorkbook.Sheets(S).Cells(2, 5) = D  'To Find Count

ActiveWorkbook.Sheets(S).Cells(2, 6) = _

ActiveWorkbook.Sheets(S).Cells(2, 6) + ActiveWorkbook.Sheets(S).Cells(C, 4)

'To Find Sum

End If

Next C

Workbooks(S).Save

Workbooks(S).Close

End If

Z = 1

D = 0

Next X

MsgBox "Macro Process Completed"

Application.Visible = True

End Sub

--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------