when playing with data many times we needs to save some unique values somewhere, that time we can use dictionary object , it does not allow to store duplicate values in it,
Dictionary object Takes two argument at the time of adding data 1) Key .2 ) Value and it returns the value by ID, so when we need to retrieve any values just we need to give ID number , A very good example is given here to understand Dictionary object :
This procedure bifurcate data from one worksheet to multiple worksheets based on multiple values exist in Column "B" on Sheet1 , first it stores all the unique from B column in dictionary and then start bifurcating data.
Hope you will like itCode:Sub DistributeDataOnSheets() Dim VarFilterData() Dim objDic As Object Dim wksSheet As Worksheet Dim lngLoop As Long Dim rngRange As Range Dim wkSSheetNew As Worksheet Set wksSheet = ThisWorkbook.Worksheets("Sheet1") VarFilterData = Application.Transpose(Intersect(wksSheet.UsedRange, wksSheet.UsedRange.Columns(2).Offset(1))) Set objDic = CreateObject("Scripting.Dictionary") For lngLoop = LBound(VarFilterData) To UBound(VarFilterData) If Not objDic.Exists(VarFilterData(lngLoop)) Then objDic.Add VarFilterData(lngLoop), VarFilterData(lngLoop) Next lngLoop Application.ScreenUpdating = False For lngLoop = 1 To objDic.Count With wksSheet.UsedRange.Columns(2) .Replace VarFilterData(lngLoop), "" Set rngRange = .SpecialCells(xlCellTypeBlanks) rngRange.Value = VarFilterData(lngLoop) End With Application.DisplayAlerts = False On Error Resume Next ThisWorkbook.Worksheets(VarFilterData(lngLoop)).Delete On Error GoTo 0: On Error GoTo -1 Application.DisplayAlerts = True Set wkSSheetNew = ThisWorkbook.Worksheets.Add wkSSheetNew.Name = VarFilterData(lngLoop) wksSheet.Rows(1).Copy wkSSheetNew.Range("A1") rngRange.EntireRow.Copy wkSSheetNew.Range("A2") Next lngLoop Application.ScreenUpdating = True MsgBox "Done",vbInformation End Sub
Reply With Quote
Bookmarks