VBA/list consolidator.bas at master · jonmoon74/VBA · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Attribute VB_Name = "Module1"
Sub facilitatorlist()
Attribute facilitatorlist.VB_Description = "collect code for range copy and remove duplicates"
Attribute facilitatorlist.VB_ProcData.VB_Invoke_Func = " \n14"

'   Collects facilitator names from drop down selected list and removes duplicates
Dim a As Integer, b As Integer, c As Integer

    Sheet1.Select
    Sheet1.Range("I2:I6000").Select
    Selection.Copy
    Sheet2.Select
    Sheet2.Range("D10").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("D10:D6010").RemoveDuplicates Columns:=1, Header:=xlNo

        Application.ScreenUpdating = False
        For a = 10 To 6010
        If Sheet2.Cells(a, 4) = "" Then
        Sheet2.Cells(a, 4).Select
        Selection.Delete shift:=xlUp
        End If
        Next a
        Application.ScreenUpdating = True

    Sheet1.Select
    Sheet1.Range("K2:K6000").Select
    Selection.Copy
    Sheet2.Select
    Sheet2.Range("E10").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("E10:E6010").RemoveDuplicates Columns:=1, Header:=xlNo

        Application.ScreenUpdating = False
        For b = 10 To 6010
        If Sheet2.Cells(b, 5) = "" Then
        Sheet2.Cells(b, 5).Select
        Selection.Delete shift:=xlUp
        End If
        Next b

    Application.ScreenUpdating = False
    Sheet2.Range("D10:D30").Select
    Selection.Copy
    Sheet2.Range("F10").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("E10:E40").Select
    Selection.Copy
    Sheet2.Range("F30").Select
    Selection.PasteSpecial Paste:=xlPasteValues


    Sheet2.Range("F10:F60").Select
    Selection.RemoveDuplicates Columns:=1, Header:=xlNo
        For c = 10 To 60
        If Sheet2.Cells(c, 6) = "" Then
        Sheet2.Cells(c, 6).Select
        Selection.Delete shift:=xlUp
        End If
        Next c
        Application.ScreenUpdating = True

    Sheet2.Range("f10").Select

End Sub