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

时间：2015-07-20 13:00:11

标签： arrays excel vba excel-vba

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

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

这就是我现在正在处理的问题，它不起作用：

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 个答案:

答案 0 :(得分：0)

20,000多次线性搜索可能会使您的应用程序变慢。最好创建一个字典来存储代码。您可以将代码加载到字典中，遍历A列，抓取任何新的部门代码，然后在阵列末端添加新发现的代码。要使用字典，需要在项目中添加对Microsoft Scripting Runtime的引用（VBA编辑器中的工具/引用）。以下功能和潜艇应易于修改以满足您的需要。我假设VariantDepartment和DepartmentWorkBookNames被声明为简单变量变量（而不是变体数组），并且当调用主子变量时，它们是空的或保持一维数组。如果它们是空的，则它们的大小应该是足以容纳代码的数组。在这种情况下，它们是基于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

输出：

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

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

答案 1 :(得分：0)

那些想知道，这是我完成的宏，一切正常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
相关问题
最新问题