VBA script required for extracting the clients from one sheet and splitting industry wise

[nagabhn]

Hi Experts,

I am newbie to Excel VBA. So I request your help in a VBA script.
I am actually having lot of clients in column "C"and their details in the same row in a sheet. I have a task to split there clients, industry wise and put it into separate sheets.
For example:Telecom client name in column "c". This has to be extracted and put into a new sheet "telecom" and copy all the details of tht client in the new sheet. This way i have multiple clients in different rows.Below is the script I have written a for one client, but muliple clients script is required. Please help.

Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 2
LSearchRow = 1

'Start copying data to row 2 in Sheet3 (row counter variable)
LCopyToRow = 1

While Len(Range("D" & CStr(LSearchRow)).Value) > 0

'If value in column D = "AIRCEL", copy entire row to Sheet2
If Range("D" & CStr(LSearchRow)).Value = "AIRCEL" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet3in next row
Sheets("Sheet3").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

[jaslake]

Hi nagabhn

Welcome to the Forum!!

Please use Code Tags around any Code you post.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

I'd suggest Filtering your Worksheet on each Industry Code then copy the Visible Cells to a new Worksheet. This all can be automated so as to happen on a Button Click.

If you need help with the Code please attach a sample file that represents what you have. The structure of your attachment should be the same structure as your actual data. Any proprietary information should be changed.

Include in the attachment any code you're currently using (whether it works or not) and an "After" worksheet that demonstrates what you wish the output to be.

To Attach a File:

1. Click on Go Advanced
2. In the frame Attach Files you will see the button Manage Attachments
3. Click the button.
4. A new window will open titled Manage Attachments - Excel Forum.
5. Click the "Add Files"... button to locate your file for uploading.
6. This will open a new window File Upload...Click "Select Files"
7. Once you have located the file to upload click the Open button. This window will close.
8. You are now back in the Manage Attachments - Excel Forum window.
9. Click the "Upload Files" button and wait until the file has uploaded.
10. Click the "Done" Button.

[nagabhn]

Hi John,

Thanks for the guidance.
Attached are the files which is currently existing(Sample Excel Report)and also required report (Reqd Output report). Hope this helps. Attaching the sample code.

Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 2
LSearchRow = 1

'Start copying data to row 2 in Sheet3 (row counter variable)
LCopyToRow = 1

While Len(Range("D" & CStr(LSearchRow)).Value) > 0

'If value in column D = "AIRCEL", copy entire row to Sheet2
If Range("D" & CStr(LSearchRow)).Value = "AIRCEL" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet3in next row
Sheets("Sheet3").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

[jaslake]

Hi nagabhn

Are there additional Industries besides these? Is the Industry Name actually included in Column 1?

	A
17	Telecom
18	Manufacturing
19	Healthcare
20	Energy
21	Transport

[nagabhn]

Hi John,
Thanks for the reply.
No. Its not specified in any column. That is the actual problem. But I have manually created a industry split excel file in which Column A and B specifies the account versus the industry.

[nagabhn]

Missed to attach the sample Industry-mapping file. Attaching the same in this reply.

[jindon]

Try the attached

[nagabhn]

Hi Jindon,

Thanks for your macro.This works for the sample report which I have provided, as you have split the "Telecom Account1" into Telecom Industry and created a new sheet.
May be my example is wrong. In actuals, I have the exact company names which will never say its telecom or healthcare industry,etc. in any column.
But I need to split the accounts industry-wise by pointing to that industry-mapping file. Their i have specified all the account names in Column A and relevant industry in Column B of same row. Hope this is clear now. Kindly revert.
Thanks in advance.

[jaslake]

Hi nagabhn

This Code is in the attached File "Industry-Mapping". The Code runs from this file with CTRL + x. The Code will ask you which File to open. Place both Files in the SAME Folder.

Option Explicit

Sub Extract_Industry()
  Dim wb1 As Workbook, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim LR1 As Long, LR2 As Long, LC2 As Long
  Dim Rng1 As Range
  Dim cel1 As Range, c As Range
  Dim myPath As String, fname As String

  Set wb1 = ThisWorkbook
  Set ws1 = wb1.Sheets("Sheet1")
  myPath = wb1.Path & "\"

  Application.ScreenUpdating = False
  With ws1
    .Range("D:D").Clear
    LR1 = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B1:B" & LR1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("D1"), Unique:=True
    ActiveWorkbook.Names.Add Name:="Industry", RefersTo:= _
                             "=OFFSET(Sheet1!$D$2,0,0,(COUNTA(Sheet1!$D:$D)-1),1)"
    Set Rng1 = .Range("Industry")
  End With

  With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = myPath   'this is the default folder shown
    .AllowMultiSelect = False
    .Filters.Add "All Files", "*.*"        'everything
    .Filters.Add "Excel Files", "*.xl*", 1  'default
    .Show
    If .SelectedItems.Count > 0 Then
      fname = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With

  Set wb2 = Workbooks.Open(fname)
  Set ws2 = wb2.Sheets("Sheet1")
  With ws2
    LC2 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious).Column
    .Range(.Cells(1, 1), .Cells(1, LC2)).Copy
  End With
  With wb2
    For Each cel1 In Rng1
      If Not Evaluate("ISREF(" & cel1.Value & "!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel1.Value
        Sheets(cel1.Value).Range("A1").PasteSpecial Paste:=8
        Sheets(cel1.Value).Range("A1").PasteSpecial
      Else
        Sheets(cel1.Value).UsedRange.Offset(1, 0).ClearContents
      End If
    Next cel1
  End With

  For Each cel1 In ws1.Range("A2:A" & LR1)
    Set c = ws2.Range("A:A").Find(cel1.Value, LookIn:=xlValues)
    If Not c Is Nothing Then
      ws2.Range(ws2.Cells(c.Row, "A"), ws2.Cells(c.Row, LC2)).Copy
      With wb2.Sheets(cel1.Offset(0, 1).Value)
        LR2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & LR2).PasteSpecial
      End With
    End If
  Next cel1

  With ws1
    .Range("D:D").Clear
  End With
  'wb2.Close True
  Application.ScreenUpdating = True
End Sub

[jindon]

If you are talking about the data which we can not even imagine, no one can help you.

[nagabhn]

Hi John,

I tried your script which is perfect for the sample report but for my original report, its creating industry specific sheets but only first row is copied to all the sheets.

Below is the new script with Vlookup function I added which will add a column B in the report and maps with the Account and the industry it belongs to using industry map file. But here I am not able to get the rows counter working properly. It copies the cells leaving lot of rows blank. Please guide me on this.

Sub IndustrySplit()

Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "'Industry"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(RC[1],'[Vert-mapping.xlsx]Sheet1'!R2C1:R33C2,2)"
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B1050"), Type:=xlFillDefault
    Range("B2:B50").Select
    Range("B1").Select

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   
   'On Error GoTo Err_Execute
   
   'Start search in row 2
   LSearchRow = 2
   
   'Start copying data to row 2 in Sheet2 (row counter variable)
   LCopyToRow = 2
   
   While Len(Range("B" & CStr(LSearchRow)).Value) > 0
   
      'If value in column B = "TELECOM", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "TELECOM" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet1").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
                        
         Sheets("Sheet1").Select
         Sheets("Sheet1").Name = "TELECOM"
   
      End If
         LSearchRow = LSearchRow + 1
      
      'If value in column B = "BFSI", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "BFSI" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet2").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
         
         LSearchRow = LSearchRow + 1
         
         Sheets("Sheet2").Select
         Sheets("Sheet2").Name = "BFSI"
         
      End If

'If value in column B = "GOVT", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "GOVT" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet3").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
         
         LSearchRow = LSearchRow + 1
         
         Sheets("Sheet3").Select
         Sheets("Sheet3").Name = "GOVT"
         
      End If

'If value in column B = "HLS", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "HLS" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet4").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
         
         LSearchRow = LSearchRow + 1
         
         Sheets("Sheet4").Select
         Sheets("Sheet4").Name = "HLS"
         
      End If
      
'If value in column B = "MFG", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "MFG" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet5").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
         LSearchRow = LSearchRow + 1
         
         Sheets("Sheet5").Select
         Sheets("Sheet5").Name = "MFG"
         
      End If
      
'If value in column B = "ENU", copy entire row to Sheet1
      If Range("B" & CStr(LSearchRow)).Value = "ENU" Then
            
         'Select row in ExcelOutputsheet to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy
         
         'Paste row into Sheet1 in next row
         Sheets("Sheet6").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste
         
         'Move counter to next row
         LCopyToRow = LCopyToRow + 1
         
         'Go back to Sheet1 to continue searching
         Sheets("Exceloutput").Select
         LSearchRow = LSearchRow + 1
         
         Sheets("Sheet6").Select
         Sheets("Sheet6").Name = "ENU"
         
      End If
      
     
      LSearchRow = LSearchRow + 1
      
   Wend
   
   'Position on cell A1
   Application.CutCopyMode = False
   Range("A1").Select
       
   MsgBox "All matching data has been copied."
   
   Exit Sub
   
Err_Execute:
   MsgBox "An error occurred."
   
End Sub

[jaslake]

Hi nagabhn

I have no ideas for your Code.

Please attach a sample file that represents what you have. The structure of your attachment should be the same structure as your actual data. Any proprietary information should be changed.

Include in the attachment any code you're currently using (whether it works or not) and an "After" worksheet that demonstrates what you wish the output to be.

To Attach a File:

1. Click on Go Advanced
2. In the frame Attach Files you will see the button Manage Attachments
3. Click the button.
4. A new window will open titled Manage Attachments - Excel Forum.
5. Click the "Add Files"... button to locate your file for uploading.
6. This will open a new window File Upload...Click "Select Files"
7. Once you have located the file to upload click the Open button. This window will close.
8. You are now back in the Manage Attachments - Excel Forum window.
9. Click the "Upload Files" button and wait until the file has uploaded.
10. Click the "Done" Button.