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
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.