CODEWITHSUNDEEP
excelvba
CRCO
CRCO

Reputation: 1

Copy rows and column to new worksheet with VBA

I really need help. In my data base on excel and the first column is made up by the codes of my clients. Every client can have different number of rows and so on. What I’m trying to do is create a VBA Macro that can go through my list of client codes and for each code copy it’s rows on the DB to a new worksheet. And to do this for all the client codes I have like on loop, after copying the first one to go automatically to the next code. Please help :(

Upvotes: 0

Views: 153

Answers (1)

JohnnieL
JohnnieL

Reputation: 1231

I hope this provides a framework for you to do what you want. Key concepts

  1. Use autofilter to identify all records for each client
  2. store client id in a dictionary to keep track of what has been processed
  3. use SpecialCells to reference filtered rows

My simple input data

enter image description here

My output

enter image description here

Let me know if its helpful

Option Explicit

Sub master_db_to_individual()

  Dim ws_in As Worksheet
  Set ws_in = ThisWorkbook.Worksheets("master_db")
  
' Not knowing the actual shape of the data, this is just a simple way to set the required range locations
  Dim r_keys As Range
  Set r_keys = Range(ws_in.Range("a2"), ws_in.Range("a2").End(xlDown))
  Dim r_all_data_with_headers As Range
  Set r_all_data_with_headers = ws_in.Range("a2").CurrentRegion
  
  
  
'create a dictionary to store client codes found
  Dim client_codes As Object
  Set client_codes = CreateObject("Scripting.Dictionary")
  

' create a new workbook for individual data
  Dim wb_individual As Workbook
  Set wb_individual = Application.Workbooks.Add
  Dim initial_ws_count As Long
  initial_ws_count = wb_individual.Worksheets.Count
  
' loop all entires in the client code column of the master data
  Dim client_code As Range
  For Each client_code In r_keys
    'test if have already processed the current row
    ' I am assuming here that the order of the client records can not be guaranteed
    If Not client_codes.Exists(client_code.Value) Then
      ' make a record that this client has been processed so if we find another row for this client we know to skip
      client_codes.Add client_code.Value, client_code.Value
      
      'ensure a sheet for this client exists by inserting and supressing error if already exists
      Dim ws_this_client As Worksheet
      Set ws_this_client = wb_individual.Worksheets.Add(after:=wb_individual.Worksheets(wb_individual.Worksheets.Count))
      ws_this_client.Name = client_code.Value
      
      'filter all rows that have this client key so they can be copied
      r_all_data_with_headers.AutoFilter field:=r_keys.Column, Criteria1:=client_code.Value, Operator:=xlFilterValues
      
      'copy filtered data with headers to new sheet
      r_all_data_with_headers.SpecialCells(xlCellTypeVisible).Copy ws_this_client.Range("a1")
      
    End If
  Next client_code
  ' remove autofilter
  r_all_data_with_headers.AutoFilter
  
  ' remove unsed sheets in new workbook
  Dim i As Integer
  Application.DisplayAlerts = False
  For i = initial_ws_count To 1 Step -1
    wb_individual.Worksheets(i).Delete
  Next i
  Application.DisplayAlerts = True
  
  ws_in.Activate
  ws_in.Range("a1").Select
  
  Set client_codes = Nothing

End Sub

Upvotes: 1

Related Questions