Rajan_Verma
04-18-2012, 12:21 AM
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.
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)).De lete
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
Hope you will like 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.
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)).De lete
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
Hope you will like it