What you need:
-column B has some empty cells [column B is column "2"
-main worksheet is "fluMerged_Aug27" ---> want to copy filtered results to the worksheet named "needEmpID"
-main worksheet & "needEmpID" have header rows
Option Explicit
Sub filterCopyToOtherSheet()
Dim shData As Worksheet, shOutput As Worksheet
Set shData = ThisWorkbook.Worksheets("fluMerged_Aug27")
Set shOutput = ThisWorkbook.Worksheets("needEmpID")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
'shOutput.Range("A5") = "Hi"
shOutput.Range("A1").CurrentRegion.Offset(1).ClearComments
Dim i As Long, j As Long, row As Long
row = 2
For i = 2 To rg.Rows.Count
If rg.Cells(i, 2).Value = "" Then
'when you assign, it has to be the same size as the destination--so use "resize" method below
shOutput.Range("A" & row).Resize(1, rg.Columns.Count).Value = rg.Rows(i).Value
row = row + 1
End If
Next i
End Sub
.bas file is here
Option Explicit
Sub Count_Rows_Example2()
Dim No_Of_Rows, No_Of_Rows1 As Integer
Dim shData As Worksheet, shOutput As Worksheet
Set shData = ThisWorkbook.Worksheets("testSheet")
Set shOutput = ThisWorkbook.Worksheets("needEmpID")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
No_Of_Rows = shData.Range("A1").End(xlDown).row 'this line of code works just like the line of code below this one!
No_Of_Rows1 = rg.Rows.Count
MsgBox No_Of_Rows
MsgBox No_Of_Rows1
End Sub
Simple calling of another subroutine
Sub DisplayMessage()
MsgBox "Hello there!"
Call SendEmail("I'm sending to you.")
End Sub
Sub SendEmail(msg As String)
MsgBox msg
End Sub
Calling a function: returns value from the function. . .
Sub DisplayMessage()
MsgBox CalculateValue(4)
End Sub
Function CalculateValue(amount As Long) As Long
CalculateValue = amount * 2
End Function
Assigning a value from another cell to a particular cell
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
'the equation on the left hand side of the "=" sign is the destination of the value from B2
shData.Range("D2").Value = shData.Range("B2").Value
End Sub
Copying a range and pasting it to another range
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
'destination area must be same size as the original data -- range sizes must be the same
shData.Range("D1:E6").Value = shData.Range("A1:B6").Value
End Sub
Dynamic Ranges
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim row As Long
row = InputBox("please enter a row number to use")
shData.Range("D1").Value = row
End Sub
or
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim row As Long
row = InputBox("please enter a row number to use")
shData.Range("D" & row).Value = row
End Sub
for COLUMNS: use "Cells" instead of "Range"
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim column As Long
column = InputBox("please enter a column number to use")
'note: Range takes a letter, but column takes a number. . .use "Cells", which returns a range of 1 cell
shData.Cells(1, column).Value = column
End Sub
Using CurrentRegion:
Sub useRanges()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
MsgBox "The address is " & rg.Address
End Sub
Workbooks & Worksheets
Sub ReadData()
Dim amount As String
amount = ActiveSheet.Range("B2").Value
MsgBox "The amount is " & amount
End Sub
Sub ReadData()
Dim amount As String
amount = Sheet2.Range("B2").Value 'Sheet2 is the (Name) of the worksheet
MsgBox "The amount is " & amount
End Sub
Use Variables
Sub ReadData()
Dim amount As Long
amount = Sheet1.Range("B2").Value
If amount > 15000 And amount < 20000 Then
MsgBox "The amount is A"
ElseIf amount > 30000 Then
MsgBox "The amount is B"
Else
MsgBox "Other"
End If
End Sub
Use Loops
Sub ReadData()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
Dim i As Long
For i = 1 To rg.Rows.Count
Debug.Print rg.Cells(i, 1).Value
Next i
End Sub
Use Arrays
Sub UseArray()
Dim arr As Variant
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
arr = shData.Range("A1").CurrentRegion
Dim i As Long
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i, 1)
Next i
End Sub
Use Dictionaries
Go to Tools menu & Select References & Check "Microsoft Scripting Runtime"
Sub UseDictionary()
Dim dict As New Dictionary
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
Dim i As Long, key As String, valuee As Long
For i = 2 To rg.Rows.Count
key = rg.Cells(i, 1).value
valuee = rg.Cells(i, 2).value
dict(key) = dict(key) + valuee
Next i
Dim currentKey As Variant
For Each currentKey In dict.Keys
Debug.Print currentKey, dict(currentKey)
Next currentKey
End Sub
Use Advanced Filter
Sub AdvancedFilter()
Dim shData As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Dim rg As Range
Set rg = shData.Range("A1").CurrentRegion
Dim criteriaRange As Range, copyRange As Range
Set criteriaRange = shData.Range("D1").CurrentRegion
Set copyRange = shData.Range("G1")
rg.AdvancedFilter xlFilterCopy, criteriaRange, copyRange
End Sub
Source: The 7 Keys Areas of Excel VBA (with code examples) - YouTube
Use this Excel file to test the above code
From within the VBA screen in Excel (Alt-F11), make sure you go to TOOLS --> select References -->check Microsoft Scripting Runtime
Option Explicit
Sub useDictionary()
Dim dict As New Dictionary
dict.Add "Apple", 60
dict.Add "Orange", 78
If dict.Exists("Apple") Then 'if Apple dictionary exists. . .
dict("Apple") = 40
Else
dict.Add ("Apple"), 40
End If
Debug.Print "Value of apple is " & dict("Apple")
End Sub
Source: (2) Excel VBA Dictionary: How to use the Dictionary (1/4) - YouTube
Sub useDictionary()
Dim dict As New Dictionary
dict.Add "Apple", 60
dict.Add "Orange", 78
dict("Apple") = dict("Apple") + 40
Debug.Print "Value of apple is " & dict("Apple")
End Sub
Creating and Printing a Dictionary
Sub createDictionary1()
Dim MyDict As Object, i As Long, MyVals As Variant
Set MyDict = CreateObject("Scripting.Dictionary")
MyVals = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).row).Value
For i = 1 To UBound(MyVals)
MyDict(MyVals(i, 1)) = MyVals(i, 2)
Next i
'Debug.Print MyDict.Keys doesn't work
Dim key As Variant
For Each key In MyDict.Keys
Debug.Print key, MyDict(key)
Next key
End Sub
See below . . .
Public Sub TestMe()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "first", 30
dict.Add "second", 40
dict.Add "third", 100
Dim key As Variant
For Each key In dict.Keys
Debug.Print key, dict(key)
Next key
End Sub
It prints:
first 30
second 40
third 100
Create a Dictionary & Paste the Dictionary's Key-Items to the Sheet
Option Explicit
Sub pasteDictOtherSheet()
Dim mydictionary As Scripting.Dictionary
Set mydictionary = New Scripting.Dictionary
'MsgBox mydictionary.Count
mydictionary.Add "Dave", 25000
mydictionary.Add "Aslam", 35000
mydictionary.Add "Krishna", 45000
'mydictionary.RemoveAll
Dim i As Long, nextBlankRow As Long
nextBlankRow = Sheet10.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
For i = 0 To mydictionary.Count - 1
'Debug.Print myDictionary.Count - 1
Cells(nextBlankRow, 1) = mydictionary.Keys(i) 'starts with row 2, col 1
Cells(nextBlankRow, 2) = mydictionary.Items(i) 'starts with row 2, col 2
nextBlankRow = nextBlankRow + 1
Next i
End Sub
Source: (2) What is Dictionary in Excel VBA - YouTube https://www.youtube.com/watch?v=A22C4DGW6vc Dinesh
If you want to use dictionary as Vlookup to match key-item pairs, view my video here; excel file is here test_9.2.22_1522
Filter by Column 6 or Column F
Option Explicit
Sub CallDataGrouper()
Call DictionaryGroupData(Range("A1:G12"), 6, True) 'this selects column 6 or F to be what we're filtering
End Sub
Sub DictionaryGroupData(rngInput As Range, keyColIndex As Long, blHeaders As Boolean)
'Must add reference to Tools > References > Microsoft Scripting Runtime
Dim i As Long
Dim rngCell As Range, rng As Range, rngTemp As Range
Dim dict As Scripting.Dictionary
Dim strVal As String
Dim varOrigItems As Variant, varUniqueItems As Variant, varKey As Variant, _
varItem As Variant
Application.ScreenUpdating = False
Set rng = rngInput.Columns(keyColIndex) 'this means rng holds column 6 in range A1:G12
Set dict = New Scripting.Dictionary
' set compare mode to text
dict.CompareMode = TextCompare
' offset by one row if range has headers
If blHeaders Then
With rngInput
Set rngInput = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
End If
' add keys and values to dictionary
With rngInput
For Each rngCell In rngInput.Columns(keyColIndex).Cells
i = i + 1
strVal = rngCell.Text
' add new key and item range
If Not dict.Exists(strVal) Then
dict.Add strVal, .Rows(i)
' merge item ranges of existing key
Else
Set rngTemp = Union(.Rows(i), dict(strVal))
dict.Remove strVal ' simply updating the item in a loop will cause a run-time error!
dict.Add strVal, rngTemp
End If
Next rngCell
End With
For Each varKey In dict.Keys
' *********************************************
'Insert your code here
' *********************************************
Debug.Print varKey & ": " & dict.Item(varKey).Address ' remove in production
Next varKey
' *********************************************
' or add code here for specific key actions
dict("A").Select
dict("A").Copy Worksheets("orders").Range("A15")
dict("B").Select
dict("B").Copy Worksheets("orders").Range("A20")
'Worksheets("test1").rng1.Copy Worksheets("test1").Range("A8")
dict("C").Select
dict("C").Copy Worksheets("c-orders").Range("A2")
' *********************************************
Application.ScreenUpdating = True
End Sub
Excel file here
Dictionary: One Key with multiple Items/Values
Option Explicit
Public Sub Demo()
Dim dictCompany As Object
Dim Emp As clsPerson
Dim i As Long
Set dictCompany = CreateObject("Scripting.Dictionary")
' Load Data into Dictionary
For i = 2 To 3
Set Emp = New clsPerson
Emp.CompanyName = Range("A" & i).Value
Emp.PersonName = Range("B" & i).Value
Emp.PersonPhone = Range("C" & i).Value
If dictCompany.Exists(i) Then
Set dictCompany(i) = Emp
Else
dictCompany.Add i, Emp
End If
Next i
Debug.Print dictCompany(2).PersonName
Debug.Print dictCompany(2).PersonPhone
Debug.Print dictCompany(3).PersonName
Debug.Print dictCompany(3).PersonPhone
End Sub
for class module named "clsPerson": Public PersonName As String, PersonPhone As String, CompanyName As String
My union video from 9.2.22 here
Option Explicit
Sub useRanges() 'Tools > References > Microsoft Scripting Runtime
Dim i, lastRow, RowCount As Long
Dim grpCol() As Variant
Dim shData, shDest, sht2 As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Set shDest = ThisWorkbook.Worksheets("sht2")
Dim dict As Object
Dim rnge As Range
Set dict = CreateObject("Scripting.Dictionary")
lastRow = shData.Range("C" & Rows.Count).End(xlUp).Row
'MsgBox lastRow 'answer is 6
RowCount = shData.Rows.Count
'MsgBox RowCount '1048576
grpCol = shData.Range("B1:B" & lastRow).Value
'grpCol(1,1) to grpCol(6,1)
shData.Range("B1:B" & lastRow).Select 'selects B1 to B6 = grpCol
For i = 1 To lastRow
'For i = 1 To i = 6 doesn't work
Debug.Print grpCol(i, 1)
Next i
Set rnge = Union(shData.Range("A1:A6"), shData.Range("D1:E6"))
rnge.Copy
shDest.Range("A10").PasteSpecial xlPasteValues
'Set rng1 = Union(Range("A1:C4"), Range("E1:F4"))
Debug.Print rnge.Address
'rnge.EntireRow.Copy shDest.Range("A1")
End Sub
Excel file here
Option Explicit
Sub BasicUnionDemo2()
Dim i, lastRow, RowCount As Long
Dim grpCol() As Variant
Dim shData, shDest, sht2 As Worksheet
Set shData = ThisWorkbook.Worksheets("test1")
Set shDest = ThisWorkbook.Worksheets("sht2")
Dim rng1 As Range
Dim item As Range
Set rng1 = Union(Range("A1:C4"), Range("D1:F4"))
'rng1.Select
'Range("B1:E10").Copy Worksheets("WithFormat").Range("B1:E10")
' doesnt work rng1.Copy Worksheets(shDest).Range("A1:E4")
Debug.Print rng1.Address
Worksheets("test1").rng1.Copy Worksheets("test1").Range("A8")
'doesnt work rng1.Copy Sheets(shDest).Range("A1").PasteSpecial xlPasteValues
For Each item In rng1
Debug.Print item.Address
Next item
End Sub
Option Explicit
Sub TestIt()
Dim Rng As Range
'Set Rng = Union(Range("A1"), Range("B1"), Range("D1"))
'Set Rng = Union(Range("A1:B1"), Range("F1"), Range("D1"))
Set Rng = Union(Range("A1:D2"), Range("F1:G2"))
Rng.Copy
'This code will run:
Range("A10").PasteSpecial xlPasteValues
MsgBox Rng.Address
End Sub
'use with tab named disjoint
Two-Dimensional Array
Let’s imagine an array called “prices” that has to store the prices of two goods (Good A and Good B). The code will be as follows:
Sub MySecondArray()
Dim prices(0 To 10, 0 To 100) As Double
Dim PricesGoodA As Interger
Dim PricesGoodB As Interger
PricesGoodA = UBound(prices, 1)
PricesGoodB = UBound(prices, 2)
Debug.Print PricesGoodA 'will print out 10
Debug.Print PricesGoodB 'will print out 100
End Sub
Worksheets("Sheet1").Cells(5, 3).Font.Size = 14
Private Sub Worksheet_Change(ByVal Target As Range)
Dim intResponse As Integer
intResponse = MsgBox("This is an automatically generated worksheet. Are you sure you want to change it?", vbOKCancel)
If intResponse = 1 Then
MsgBox ("Worksheet value changed.")
Else
'Application.EnableEvents = False
Application.Undo
MsgBox ("Change not completed.")
'Application.EnableEvents = True
End If
End Sub
Use with Excel file here
Video is here