在Excel中循环列并将唯一字符串添加到数组

I am trying to write a program in VBA at the moment which is to be run in Excel. I am quite stuck right now because I am not very familiar with VBA and doing a search doesn't come up with my specific problem.

我正在尝试在VBA中编写一个程序,该程序将在Excel中运行。我现在很困,因为我对VBA不是很熟悉,而且搜索没有提出我的具体问题。

I have a column in Excel which has 20,000+ hostnames for PC's on our network. What I need to do is be able to start at A2 and get the data in that cell, parse out the 5th and 6th characters only and check if those two characters are in an array called VariantDepartments. If the characters are in the array, I need to move to A3 and do it again. If the characters are not in the array, I need to add them to the end of the VariantDepartments array and then add those two characters plus the word "Workbook" to another array called DepartmentWorkBookNames at which point I index both arrays +1 and move to A3.

我在Excel中有一个专栏,在我们的网络上有20000多个PC主机名。我需要做的是能够从A2开始并获取该单元格中的数据,仅解析第5和第6个字符,并检查这两个字符是否在名为VariantDepartments的数组中。如果字符在数组中,我需要移动到A3并再次执行。如果字符不在数组中,我需要将它们添加到VariantDepartments数组的末尾,然后将这两个字符加上单词“Workbook”添加到另一个名为DepartmentWorkBookNames的数组中,此时我将两个数组都编入索引+1并移动到A3。

This is what I am working on right now and it does not work:

这就是我现在正在做的工作,它不起作用:

Sub VulnerabilityMacroFinal()
Dim VariantDepartments As Variant
Dim departments As Variant
Dim Department As String
Dim VariantAssetTypes As Variant
Dim AssetTypes As Variant
Dim AssetType As String
Dim Property As String
Dim FileName As String
Dim PropArray() As String
Dim strFile As String  

'Opening file & getting property name
strFile = Application.GetOpenFilename
If strFile <> "False" Then Workbooks.Open strFile
FileName = ActiveWorkbook.Name
PropArray = Split(FileName, "-")
Property = PropArray(0)

'Setting asset types
VariantAssetTypes = Array("PC", "Server", "Other Assets")

'Program Start
Sheets("AllVulnerabilities").Select

'sorting out unnecessary types
ActiveSheet.UsedRange.AutoFilter Field:=5, Criteria1:=Array( _
"01-Adobe", "02-Apache", "06-Chrome", "09-Firefox", "13-Java", "16-Microsoft", _
"38-VNC"), Operator:=xlFilterValues

'Selecting the whole sheet
Cells.Select
'Creating sheets for different asset types
For Each AssetTypes In VariantAssetTypes
'Making variable a C String to make it easier to check in If statements
AssetType = CStr(AssetTypes)
    If AssetType = "PC" Then
        'Parsing out the non local PC assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:=Property & "D*"
        ActiveSheet.Range("A:A,B:B,C:C,D:D,E:E,F:F").AutoFilter Field:=1
    ElseIf AssetType = "Server" Then
        'Selecting original sheet
        Sheets("AllVulnerabilities").Select
        'Parsing out the non local Server assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:=Property & "*", _
        Operator:=xlAnd, Criteria2:="<>" & Property & "D*"
    ElseIf AssetType = "Other Assets" Then
        'Selecting original sheet
        Sheets("AllVulnerabilities").Select
        'Parsing out the non local Server assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:="<>" & Property & "*"
    End If
    'Copying all info on sheet
    ActiveSheet.UsedRange.Copy
    'Selecting new sheet
    Sheets.Add.Name = Property & " " & AssetType
    'Selecting new sheet
    Sheets(Property & " " & AssetType).Select
    'Pasting data to new sheet
    ActiveSheet.Paste
    'Removing unnecessary colums
    Range("A:A,B:B,D:D,G:G,H:H,J:J,K:K").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    'Auto adjusting column widths
    Range("A:A,B:B,C:C,D:D,E:E,F:F").EntireColumn.AutoFit
    ActiveWorkbook.Worksheets(Property & " " & AssetType).Copy
    'Close Workbook withoutsaving
    ActiveWorkbook.Close savechanges:=False
Next AssetTypes

Sheets(Property & " PC").Select
'THIS IS WHERE THE ARRAY SHOULD BE CREATED.

For Each departments In VariantDepartments
Department = CStr(departments)
    Sheets(Property & " PC").Select
    'Parsing out the non local assets for EH
    ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:=Property & "D" & Department & "*"
    'Copying all info on sheet
    ActiveSheet.UsedRange.Copy
    'Selecting new sheet
    Sheets.Add.Name = Property & Department
    'Selecting new sheet
    Sheets(Property & Department).Select
    'Pasting data to new sheet
    ActiveSheet.Paste
    'Auto adjusting column widths
    Range("A:A,B:B,C:C,D:D,E:E,F:F").EntireColumn.AutoFit
    ActiveWorkbook.Worksheets(Property & Department).Copy
    'Close Workbook withoutsaving
    ActiveWorkbook.Close savechanges:=False
    'Set PC Worksheet to be unfiltered
    Worksheets(Property & " PC").ShowAllData
Next departments
   'Completed
   ActiveWindow.Close savechanges:=False
'Message box which appears when everything is done
MsgBox "Done!"

End Sub

2 个解决方案

#1

20,000+ linear searches could slow your application to a crawl. It is a better idea to create a dictionary to store the codes. You can load the codes to a dictionary, iterate through column A grabbing any new department codes, then tack the newly discovered codes on the ends of the arrays. To use a dictionary, you need to add a reference to Microsoft Scripting Runtime to your projects (tools/references in the VBA editor). The following functions and subs should be easily modifiable for your purposes. I am assuming that VariantDepartment and DepartmentWorkBookNames are declared as simple Variant variables (and not as arrays of variants) and that when the main sub is invoked they are either empty or hold 1-dimensional arrays. If they are empty, they are dimensioned to be arrays large enough to hold the codes. In this case, they are 1-based meaning that their indexing starts at 1. The code would have to be modified slightly to make them 0-based. To test it, I created a small amount of dummy data in column A and checked that the two arrays were updated appropriately:

20,000多次线性搜索可能会使您的应用程序变慢。最好创建一个字典来存储代码。您可以将代码加载到字典中,遍历A列,抓取任何新的部门代码,然后在阵列末端添加新发现的代码。要使用字典,您需要向项目添加对Microsoft Scripting Runtime的引用(VBA编辑器中的工具/引用)。以下功能和潜艇应易于修改以满足您的需要。我假设VariantDepartment和DepartmentWorkBookNames被声明为简单的Variant变量(而不是变体数组),并且当调用main sub时它们是空的或者保持一维数组。如果它们是空的,则它们的大小应该是足以容纳代码的数组。在这种情况下,它们是基于1的,这意味着它们的索引从1开始。代码必须稍微修改以使它们从0开始。为了测试它,我在A列中创建了少量虚拟数据,并检查两个数组是否已正确更新:

Function DictFromArray(items As Variant) As Dictionary
    Dim i As Long
    Dim d As New Dictionary
    If Not IsArray(items) Then
        Set DictFromArray = d 'empty dictionary
        Exit Function
    End If
    For i = LBound(items) To UBound(items)
        If Not d.Exists(items(i)) Then
            d.Add items(i), ""
        End If
    Next i
    Set DictFromArray = d
End Function

Sub AddDepartments(VDepts As Variant, DNames As Variant)
    Dim departments As Dictionary
    Dim newDepartments As New Collection
    Dim i As Long, m As Long, k As Long, n As Long
    Dim code As String

    Set departments = DictFromArray(VDepts)
    n = Range("A:A").Rows.Count
    n = Cells(n, "A").End(xlUp).Row
    For i = 2 To n
        code = Cells(i, "A").Value
        code = Mid(code, 5, 2)
        If Not departments.Exists(code) Then newDepartments.Add code
    Next i
    n = newDepartments.Count
    If n > 0 Then
        If IsArray(VDepts) Then
            m = UBound(VDepts)
            ReDim Preserve VDepts(LBound(VDepts) To m + n)
        Else
            m = 0
            ReDim VDepts(1 To n)
        End If
        If IsArray(DNames) Then
            k = UBound(DNames)
            ReDim Preserve DNames(LBound(DNames) To k + n)
        Else
            k = 0
            ReDim DNames(1 To n)
        End If
        For i = 1 To n
            VDepts(m + i) = newDepartments(i)
            DNames(k + i) = newDepartments(i) & "Workbook"
        Next i
    End If
End Sub

Sub test()
    Dim VariantDepartment As Variant
    Dim DepartmentWorkBookNames As Variant
    Dim i As Long

    VariantDepartment = Array("CD", "FX")
    DepartmentWorkBookNames = Array("CDWorkbook", "FXWorkbook")
    AddDepartments VariantDepartment, DepartmentWorkBookNames
    For i = LBound(VariantDepartment) To UBound(VariantDepartment)
        Debug.Print VariantDepartment(i)
    Next i
    For i = LBound(DepartmentWorkBookNames) To UBound(DepartmentWorkBookNames)
        Debug.Print DepartmentWorkBookNames(i)
    Next i
End Sub

Output:

CD
FX
AB
FF
GG
GH
CDWorkbook
FXWorkbook
ABWorkbook
FFWorkbook
GGWorkbook
GHWorkbook

The last 4 values in each array correspond to the new values in the 5th and 6th positions in the entries in column A. You can comment out the two lines in which the variants are assigned arrays using the Array() function and verify that it succeeds in populating those two variables correctly.

每个数组中的最后4个值对应于A列条目中第5和第6个位置的新值。您可以使用Array()函数注释掉变量分配数组的两行,并验证它是否成功正确填充这两个变量。

#2

Those wondering, this is my completed macro, everything works 100% and from input to completion is 20-60 seconds.

那些想知道,这是我完成的宏,一切工作100%,从输入到完成是20-60秒。

Sub VulnerabilityMacroFinal()
Dim VariantDepartments As Variant
Dim departments As Variant
Dim Department As String
Dim VariantAssetTypes As Variant
Dim AssetTypes As Variant
Dim AssetType As String
Dim Property As String
Dim FileName As String
Dim PropArray() As String
Dim strFile As String
Dim i As Long


'Opening file & getting property name
strFile = Application.GetOpenFilename
If strFile <> "False" Then Workbooks.Open strFile
FileName = ActiveWorkbook.Name
PropArray = Split(FileName, "-")
Property = PropArray(0)

'Setting asset types
VariantAssetTypes = Array("PC", "Server", "Other Assets")

'Program Start
Sheets("AllVulnerabilities").Select

'sorting out unnecessary types
ActiveSheet.UsedRange.AutoFilter Field:=5, Criteria1:=Array( _
"01-Adobe", "02-Apache", "06-Chrome", "09-Firefox", "13-Java", "16-Microsoft", _
"38-VNC"), Operator:=xlFilterValues

'Saving sorted workbook
ActiveWorkbook.SaveAs FileName:="\\" & Property & "\shared\IT\PC Remediation\" & Property & "_Remediation_" & Format(Date, "yyyymmdd") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'Selecting the whole sheet
Cells.Select
'Creating sheets for different asset types
For Each AssetTypes In VariantAssetTypes
'Making variable a C String to make it easier to check in If statements
AssetType = CStr(AssetTypes)
    If AssetType = "PC" Then
        'Parsing out the non local PC assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:=Property & "D*"
        ActiveSheet.Range("A:A,B:B,C:C,D:D,E:E,F:F").AutoFilter Field:=1
    ElseIf AssetType = "Server" Then
        'Selecting original sheet
        Sheets("AllVulnerabilities").Select
        'Parsing out the non local Server assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:=Property & "*", _
        Operator:=xlAnd, Criteria2:="<>" & Property & "D*"
    ElseIf AssetType = "Other Assets" Then
        'Selecting original sheet
        Sheets("AllVulnerabilities").Select
        'Parsing out the non local Server assets
        ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:="<>" & Property & "*"
    End If
    'Copying all info on sheet
    ActiveSheet.UsedRange.Copy
    'Selecting new sheet
    Sheets.Add.Name = Property & " " & AssetType
    'Selecting new sheet
    Sheets(Property & " " & AssetType).Select
    'Pasting data to new sheet
    ActiveSheet.Paste
    'Removing unnecessary colums
    Range("A:A,B:B,D:D,G:G,H:H,J:J,K:K").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    'Auto adjusting column widths
    Range("A:A,B:B,C:C,D:D,E:E,F:F").EntireColumn.AutoFit
    ActiveWorkbook.Worksheets(Property & " " & AssetType).Copy
    'Saving new workbook
    ActiveWorkbook.SaveAs FileName:="\\" & Property & "\shared\IT\PC Remediation\" & Property & AssetType & Format(Now, "yyyymmdd") & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'Close Workbook withoutsaving
    ActiveWorkbook.Close savechanges:=False
Next AssetTypes

Sheets(Property & " PC").Select
AddDepartments VariantDepartments
For Each departments In VariantDepartments
Department = CStr(departments)
    Sheets(Property & " PC").Select
    'Parsing out the non local assets for EH
    ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:=Property & "D" & Department & "*"
    'Copying all info on sheet
    ActiveSheet.UsedRange.Copy
    'Selecting new sheet
    Sheets.Add.Name = Property & Department
    'Selecting new sheet
    Sheets(Property & Department).Select
    'Pasting data to new sheet
    ActiveSheet.Paste
    'Auto adjusting column widths
    Range("A:A,B:B,C:C,D:D,E:E,F:F").EntireColumn.AutoFit
    ActiveWorkbook.Worksheets(Property & Department).Copy
    'Saving new workbook
    ActiveWorkbook.SaveAs FileName:="\\" & Property & "\shared\IT\PC Remediation\" & Property & Department & Format(Now, "yyyymmdd") & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'Close Workbook withoutsaving
    ActiveWorkbook.Close savechanges:=False
    'Set PC Worksheet to be unfiltered
    Worksheets(Property & " PC").ShowAllData
Next departments
   'Completed
   ActiveWindow.Close savechanges:=False
'Message box which appears when everything is done
MsgBox "Done!"

End Sub
'Function checks if value exists in collection
Public Function Exists(ByVal oCol As Collection, ByVal vKey As Variant) As     Boolean

On Error Resume Next
oCol.Item vKey
Exists = (Err.Number = 0)
Err.Clear

End Function

Sub AddDepartments(VDepts As Variant)
Dim newDepartments As New Collection, a
Dim i As Long, m As Long, n As Long
Dim code As String

'Getting A column info
n = Range("A:A").Rows.Count
n = Cells(n, "A").End(xlUp).Row
'Creating the Collection with all the Departments
For i = 2 To n
    'Getting cell value in Column A (Hostname)
    code = Cells(i, "A").Value
    'Getting department code from Hostname
    code = Mid(code, 5, 2)
    'Checking collection to see if it exists
    If Not Exists(newDepartments, code) Then newDepartments.Add code, code
Next i
n = newDepartments.Count
'Moving everything from collection to variant array
If n > 0 Then
    If IsArray(VDepts) Then
        m = UBound(VDepts)
        ReDim Preserve VDepts(LBound(VDepts) To m + n)
    Else
        m = 0
        ReDim VDepts(1 To n)
    End If
    For i = 1 To n
        VDepts(m + i) = newDepartments(i)
    Next i
End If
End Sub