留在VBA中的function

我有一个输出文件是通过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多套输出。

任何帮助将不胜感激

韦恩

Answer 1

而不是使用所有这些“如果，那么”我会使用一个select案例，这是另一种方式。

 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 2

Range.TextToColumns方法可以开始对单元信息进行拆分和修剪。 批量操作几乎总是比循环更快，并通常提供更好的错误控制。 一旦分割和修剪，通过一个变体数组循环到一个Select Case语句应该将值转换到它们各自的字段。 没有保证完整的logging集的讨论，所以我避免简单地将转置的数据全部丢弃 。

 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 

由于我不打算重新input样本数据，这在很大程度上是未经testing的。 如果字段丢失，他们可能拼写错误。

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 

等等

这样，每个语句都将被testing并运行（如果它们通过If语句中的子句）。

要仅select冒号“：”后面的字符，请尝试：

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

Answer 4

这里也是TextToColumn ，然后使用rangeAreas来复制和粘贴

  Sub Button1_Click() Dim RangeArea As Range Dim ws As Worksheet, sh As Worksheet Set ws = Sheets("Input") Set sh = Sheets("Output") Application.DisplayAlerts = 0 Application.ScreenUpdating = 0 With ws .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True .Range(.Range("A1"), .Range("A1").End(xlDown)).Copy sh.Range("A1").PasteSpecial xlPasteValues, Transpose:=True For Each RangeArea In .Columns("A").SpecialCells(xlCellTypeConstants, 23).Areas RangeArea.Offset(, 1).Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True Next RangeArea End With Application.CutCopyMode = 0 End Sub 

Answer 5

这个问题已经回答了，但是午饭后我想：如果真的这个块可以是千块，为什么不使用一个数组，我用300块广告testing它非常快。

 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