Question

我有一个输出文件是通过power-shell生成的，该文件以下列格式提供共享转储和权限：

我希望在VBA中编写一个模块，在这个模块中，我可以将原始数据放在名为Input的工作表中，并对marco感兴趣，以便输出如下所示：

我对VBA很新，但改变了一些代码，我提供了Stackoverflow社区，我已经做到了这一点：

Sub PathAccessSplit()

Dim wsFrom, wsTo As Worksheet
Dim rowFrom, rowTo, lastRow As Long
Dim cellVal As String

Set wsFrom = Sheets("Input")
Set wsTo = Sheets("Output")

lastRow = wsFrom.Cells(wsFrom.Rows.Count, "A").End(xlUp).Row
rowTo = 1

For rowFrom = 1 To lastRow
cellVal = wsFrom.Cells(rowFrom, 1).Text

If (Left(cellVal, 4) = "Name") Then
  wsTo.Cells(rowTo, 1).Value = cellVal
ElseIf (Left(cellVal, 8) = "FullName") Then
  wsTo.Cells(rowTo, 2).Value = cellVal
ElseIf (Left(cellVal, 18) = "InheritanceEnabled") Then
  wsTo.Cells(rowTo, 3).Value = cellVal
ElseIf (Left(cellVal, 13) = "InheritedFrom") Then
  wsTo.Cells(rowTo, 4).Value = cellVal
ElseIf (Left(cellVal, 17) = "AccessControlType") Then
  wsTo.Cells(rowTo, 5).Value = cellVal
ElseIf (Left(cellVal, 12) = "AccessRights") Then
  wsTo.Cells(rowTo, 6).Value = cellVal
ElseIf (Left(cellVal, 7) = "Account") Then
  wsTo.Cells(rowTo, 7).Value = cellVal
ElseIf (Left(cellVal, 16) = "InheritanceFlags") Then
  wsTo.Cells(rowTo, 8).Value = cellVal
ElseIf (Left(cellVal, 11) = "IsInherited") Then
  wsTo.Cells(rowTo, 9).Value = cellVal
ElseIf (Left(cellVal, 16) = "PropagationFlags") Then
  wsTo.Cells(rowTo, 10).Value = cellVal
ElseIf (Left(cellVal, 11) = "AccountType") Then
  wsTo.Cells(rowTo, 11).Value = cellVal

  rowTo = rowTo + 1
End If

但是输出只是转置输出，只输出一组结果，而不是第二组权限。

我需要VBA足够强大以处理1000多组输出。

非常感谢任何帮助

Wayne

Answer 1

Range.TextToColumns method可以开始分割和修剪细胞信息。批量操作几乎总是比循环更快，并且通常提供更好的错误控制。拆分和修剪后，将变量数组循环到Select Case statement应该将值转换为各自的字段。没有关于保证完整记录集的讨论，所以我避免简单地将转置数据转储回 en masse 。

Sub PathAccessSplit()
    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim v As Long, rwTo As Long, vVALs As Variant

    Set wsFrom = Sheets("Input")
    Set wsTo = Sheets("Output")

    With wsTo
        With .Cells(1, 1).CurrentRegion
            With .Resize(Application.Max(1, .Rows.Count - 1), .Columns.Count).Offset(1, 0)
                .ClearContents
                rwTo = 1
            End With
        End With
    End With

    With wsFrom
        With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            With .Columns(1)
                .TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
                               ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, _
                               Comma:=False, Space:=False, Other:=True, OtherChar:=":", _
                               FieldInfo:=Array(Array(1, 1), Array(2, 1))
                .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
                               FieldInfo:=Array(0, 2)
            End With

            vVALs = .Columns("A:B").Value2

        End With
    End With

    With wsTo
        For v = LBound(vVALs, 1) To UBound(vVALs, 1)
            Select Case Trim(LCase(vVALs(v, 1)))
                Case "name"
                    rwTo = rwTo + 1
                    .Cells(rwTo, 1) = vVALs(v, 2)
                Case "fullname"
                    .Cells(rwTo, 2) = vVALs(v, 2)
                Case "inheritanceenabled"
                    .Cells(rwTo, 3) = vVALs(v, 2)
                Case "inheritancefrom"
                    .Cells(rwTo, 4) = vVALs(v, 2)
                Case "accesscontroltype"
                    .Cells(rwTo, 5) = vVALs(v, 2)
                Case "accessrights"
                    .Cells(rwTo, 6) = vVALs(v, 2)
                Case "account"
                    .Cells(rwTo, 7) = vVALs(v, 2)
                Case "inheritanceflags"
                    .Cells(rwTo, 8) = vVALs(v, 2)
                Case "isinherited"
                    .Cells(rwTo, 9) = vVALs(v, 2)
                Case "propagationflags"
                    .Cells(rwTo, 10) = vVALs(v, 2)
                Case "accounttype"
                    .Cells(rwTo, 11) = vVALs(v, 2)
                Case Else
                    'space - do nothing
            End Select
        Next v
    End With

End Sub

由于我不打算重新输入样本数据，因此很大程度上未经测试。如果字段丢失，则可能拼写错误。

Answer 2

而不是使用所有这些“if，then”我会使用一个精选案例，这是另一种方式。

Sub wsfrom_Pulsante1_Click()
Dim wsFrom  As Worksheet, wsTo As Worksheet             'otherwise the first is a variable
Dim rowFrom As Long, rowTo As Long, lastRow As Long
Dim cellVal As String
Set wsFrom = Sheets("Input")
Set wsTo = Sheets("Output")
lastRow = wsFrom.Cells(wsFrom.Rows.Count, "A").End(xlUp).Row
rowTo = 1
For rowFrom = 1 To lastRow
cellVal = wsFrom.Cells(rowFrom, 1).text
If cellVal = "" Then    'the blanck row between one block to another
    rowTo = rowTo + 1   'ad 1 for the next row in wsTo
End If
On Error Resume Next    'jump the error Left(cellVal, InStr(cellVal, " ") - 1) because the cell is ""
Select Case Left(cellVal, InStr(cellVal, " ") - 1)
    Case "Name"
        wsTo.Cells(rowTo, 1).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "FullName"
        wsTo.Cells(rowTo, 2).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "InheritanceEnabled"
        wsTo.Cells(rowTo, 3).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "InheritedFrom"
        wsTo.Cells(rowTo, 4).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "AccessControlType"
        wsTo.Cells(rowTo, 5).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "AccessRights"
        wsTo.Cells(rowTo, 6).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "Account"
        wsTo.Cells(rowTo, 7).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "InheritanceFlags"
        wsTo.Cells(rowTo, 8).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "IsInherited"
        wsTo.Cells(rowTo, 9).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "PropagationFlags"
        wsTo.Cells(rowTo, 10).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
    Case "AccountType"
        wsTo.Cells(rowTo, 11).Value = Mid(cellVal, (InStr(cellVal, ":") + 1))
End Select
Next rowFrom
End Sub

Answer 3

与您的If...Else结构有关。因为您使用的是ElseIf，所以实际上只会运行其中一个语句。

您需要将语法更改为仅使用If语句，如下所示：

If (Left(cellVal, 4) = "Name") Then
  wsTo.Cells(rowTo, 1).Value = cellVal
End If
If (Left(cellVal, 8) = "FullName") Then
  wsTo.Cells(rowTo, 2).Value = cellVal
End If
If (Left(cellVal, 18) = "InheritanceEnabled") Then
  wsTo.Cells(rowTo, 3).Value = cellVal
End If

等

通过这种方式，将测试并运行每个语句（如果它们通过If语句中的子句）。

要仅选择冒号后面的字符：＆＃39;，请尝试：

If (Left(cellVal, 4) = "Name") Then 
    wsTo.Cells(rowTo, 1).Value = Right(cellVal, Len(cellVal) - InStr(cellVal, ":") - 1) 
End If

Answer 4

此处还有val alotOfIDs : Seq[ID] = (1 to 1000000) map { i => ID(i)} val results = alotOfIDs map ServicePool.queryService，然后使用TextToColumn来复制和粘贴

rangeAreas

Answer 5

问题已得到解答，但午饭后我想：如果真的块可以是千块，为什么不使用一个阵列，我用300块广告进行测试，它非常快。

Sub wsfrom_Pulsante2_Click()
Dim wsFrom  As Worksheet, wsTo As Worksheet
Dim lastRow As Long
Set wsFrom = Sheets("Input")
Set wsTo = Sheets("Output")
lastRow = wsFrom.Cells(wsFrom.Rows.Count, "A").End(xlUp).Row
lastBlock = Round((lastRow + 1) / 12, 0)    'to count how many block (11 item + 1 blanck row) are in the range

Dim arr As Variant
ReDim arr(1 To lastBlock, 1 To 11)          'redim 1th diemnsion array to exactly no off block
i = 1
For x = 1 To lastBlock
        For y = 1 To 11
            arr(x, y) = Mid(Cells(i, 1), (InStr(Cells(i, 1), ":") + 1))
            i = i + 1
        Next y
        i = i + 1                           'add one to jump blanck row
Next x
wsTo.Range("A2:K" & lastBlock) = arr        'put the value on defined sheet
End Sub

VBA中的左功能

5 个答案: