Tuesday, 2 October 2012

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


End If

Z = 1
D = 0

Next X

MsgBox "Macro Process Completed"
Application.Visible = True
End Sub


No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts