левой функции в VBA

Question

У меня есть выходной файл, который генерируется с помощью силовой оболочки, которая обеспечивает сброс акций и там разрешение в следующем формате:

Я ищу закодировать в VBA а модуль, где я могу упасть исходные данные в листе под названием Input и забавной Марко поэтому выход выглядит следующим образом:

Я м новичок в VBA, но изменяя некоторый код при условии, мой Stackoverfl ой общины я получил это далеко:

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 

Но выход только перестановкой выход, и только вывод один набор результатов, не двигаясь на 2 второй набор разрешений.

Мне нужен VBA, чтобы быть достаточно прочным, чтобы обрабатывать более 1000 наборов выходов.

Любая помощь будет принята с благодарностью

Wayne

Answer 1

, а не использовать все эти «если», то я бы использовал случай выбора, это другой способ.

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

Это связано с вашей If...Else структурой. Поскольку вы используете ElseIf, тогда будет только один из этих операторов.

Вы должны изменить синтаксис использовать только если заявления, например, так:

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).

Чтобы выбрать только символы после двоеточия «:», попробуйте:

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

Answer 3

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 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

вопрос был дан ответ, , но после обеда я думал: если на самом деле блок может быть тысячи, почему дон» t использовать один массив, я тестирую его с 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