1

私がしなければならない少し複雑な仕事ですが、私は試みて説明します。Webサイトにインポートしている23000行のデータを含むExcelファイルがあります。それぞれに次のようなフィールドがあります。

Category | other data | other data 2 

Foods/Dog/Treats Pre-Pack | 1223 | image.jpg

各行を取得し、その下に「/」ごとに新しい行を追加する必要があるため、上記を次のように変換します。

Category | other data | other data 2 

[blank in original line] | 1223 | image.jpg

Foods | [blank field] | [blank field]

Foods/Dog | [blank field] | [blank field]

Foods/Dog/Treats Pre-Pack | [blank field] | [blank field]

したがって、スクリプトはカテゴリごとに新しい行を追加する必要がありますが、元のカテゴリはその前に保持されます。したがってcategory/category2/category 3、次の4行になります。[blank] - category - category/category2 - category/category2/category 3

誰かがこれを行う方法やスクリプトを知っていますか？

ありがとう、サイモン

注：ワークシートは「テスト」と呼ばれ、カテゴリ列はE2から始まり、E23521に進みます。

私は次のスクリプトを持っています：

Sub test()
    Dim a, i As Long, ii As Long, e, n As Long
    Dim b(), txt As String, x As Long
    With Range("a1").CurrentRegion
        a = .Value
        txt = Join$(Application.Transpose(.Columns(5).Value))
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "/"
            x = .Execute(txt).Count * 2
        End With
        ReDim b(1 To UBound(a, 1) + x, 1 To UBound(a, 2))
        For i = 1 To UBound(a, 1)
            If a(i, 5) <> "" Then
                For Each e In Split(a(i, 5), "/")
                    n = n + 1
                    For ii = 1 To UBound(a, 2)
                        b(n, ii) = a(i, ii)
                    Next
                    b(n, 5) = Trim$(e)
                Next
            End If
        Next
        .Resize(n).Value = b
    End With
End Sub

これにより、必要に応じて新しい行が作成されるように見えますが、スラッシュ構造がそれぞれ上に移動し続けるわけではありません。また、すべての新しい行に空白行を追加して、元のカテゴリ値を空白にしないでください。

解決済み：

Sub splitEmUp()
    Dim splitter() As String 'this is storage space for the split function
    Dim i As Integer ' main-loop for counter "which cell we are on"
    Dim j As Integer ' splitter for-loop counter "which section of the split are we on"
    Range("E2").Activate 'starting in cell e2 because row 1 is headers and category is located in the B column

   For i = 0 To 24000 'from beginning to end i=0 means e2, i=1 means e3
        ActiveCell.Offset(i, 0).Value = Replace(ActiveCell.Offset(i, 0).Value, " / ", "!@#")
        splitter = Split(ActiveCell.Offset(i, 0), "/") 'split the cell based on / and store it in splitter
        If (UBound(splitter)) > 0 Then 'if a split occurred
            ActiveCell.Offset(i, 0).Value = "" 'set the activecell to blank
            Debug.Print i
            ActiveCell.Offset(i + 1, 0).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'insert a new row and shift everything down

            ActiveCell.Offset(i + 1, 0).Value = splitter(0) 'initialize the "Down" cells
            ActiveCell.Offset(i + 1, 0).Value = Replace(ActiveCell.Offset(i + 1, 0).Value, "!@#", " / ")
            For j = 1 To UBound(splitter)
                ActiveCell.Offset(i + j + 1).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'create another row if it needs to
                ActiveCell.Offset(i + (j + 1), 0).Value = ActiveCell.Offset(i + j).Value & "/" & splitter(j) 'fill out the new row
                ActiveCell.Offset(i + (j + 1), 0).Value = Replace(ActiveCell.Offset(i + (j + 1), 0).Value, "!@#", " / ")
            Next
            i = i + UBound(splitter) + 1 'need to step I past the new cells
            ReDim splitter(0)
            Erase splitter 'erase and eliminate splitter to avoid carry over.

        End If
    Next

End Sub
4

2 に答える 2

0

これは別のソリューションの例です。Excelでセルを行に分割する方法。状況に合わせて少しだけ変更しました。

Public Sub solutionJook()
  Dim arr() As Variant
  Dim arrSum() As Variant
  Dim arrResult() As Variant
  Dim arrTemp As Variant

  Dim i As Long
  Dim j As Long
  Dim h As Long
  Dim lngSplitColumn As Long
  'input of array to seperate -> should cover all columns+rows of your data
  arr = Range("A1:C2")
  'specify which column has the values to be split up -> here this is the category column
  lngSplitColumn = 2

  'using the boundries of the given range,
  'arrSum has now always the right boundries for the first dimension
  ReDim Preserve arrSum(LBound(arr, 2) To UBound(arr, 2), 1 To 1)

  'create the array with seperated A B C
  For i = LBound(arr, 1) To UBound(arr, 1)
    'use split to make Foods/Dog/Treats Pre-Pack into an array, using '\' (chr(92)) as indicator
    arrTemp = Split(arr(i, lngSplitColumn), Chr(92))
    'every value of arrTemp creates a new row
    For j = LBound(arrTemp) To UBound(arrTemp)
      'loop through all input columns and create the new row
      For h = LBound(arr, 2) To UBound(arr, 2)
        If h = lngSplitColumn Then
          'setup the value of the splitted column
          Dim k as long
          arrSum(h, UBound(arrSum, 2)) = arrTemp(LBound(arrTemp))
          for k = LBound(arrTemp)+1 to j
            arrSum(h, UBound(arrSum, 2)) = arrSum(h, UBound(arrSum, 2)) & "\" & arrTemp(k)  'set Foods Foods/Dog Foods/Dog/Treats Pre-Pack
          next k
        Else
          'setup the value of any other column
          arrSum(h, UBound(arrSum, 2)) = arr(i, h) 'set Value of Column h
        End If
      Next h

      ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
                            LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
    Next j
  Next i

  'clean up last empty row (not realy necessary)
  ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
                        LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))

  'setup transposed result array
  ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
                  LBound(arrSum, 1) To UBound(arrSum, 1))

  'transpose the array
  For i = LBound(arrResult, 1) To UBound(arrResult, 1)
    For j = LBound(arrResult, 2) To UBound(arrResult, 2)
      arrResult(i, j) = arrSum(j, i)
    Next j
  Next i

  'specify target range
  Range(Cells(1, 5), Cells(UBound(arrResult, 1), 4 + UBound(arrResult, 2))) = arrResult

End Sub

ただし、ターゲット範囲を調整する必要がある場合があります。

Cells(1,5)->E1が貼り付けの開始点です

于 2012-10-29T17:39:44.543 に答える
0

これが私が思いついたものです。ワークブックに合わせてシート名を変更してください。また、セルの入力範囲に合わせて入力範囲を変更してください。

Function SplitAndWrite(inputCell As Range, TopOfOutputRange As Range, sep As String) As Range

Dim texts() As String, i As Integer, outputText As String
texts = Split(inputCell.Value, sep)
outputText = ""
TopOfOutputRange = ""   'your blank line
For i = LBound(texts) To UBound(texts)
    outputText = outputText & sep & texts(i)
    TopOfOutputRange.Offset(i + 1) = outputText
Next i

Set SplitAndWrite = TopOfOutputRange.Offset(UBound(texts) + 1)

End Function

Sub THEPOPULATOR()

    Dim s3 As Worksheet, s4 As Worksheet
    Set s3 = Sheets("Sheet1")
    Set s4 = Sheets("Sheet2")
    Dim inputrange As Range, c As Range, outputrange As Range
    Set outputrange = s4.Range("A1")
    Set inputrange = s3.Range(s3.Cells(2, 1), s3.Cells(2, 1).End(xlDown)) 'cells(2,1) = "A1". change this to your top input cell. then the second half will find the bottom cell on its own. This is the same as pressing Ctrl+down

    For Each c In inputrange
        s3.Range(c.Offset(0, 1), c.Offset(0, c.End(xlToRight).Column)).Copy outputrange.Offset(1, 1)
        Set outputrange = SplitAndWrite(c, outputrange.Offset(1), "/")
    Next c

End Sub
于 2012-10-29T17:34:30.217 に答える