Question

我有20k记录的电子表格。它包含A栏——J栏D有多个条目,按英镑分列。我愿将D栏数据与A-C和E-J栏中的数据分开。

投入:

Blue    Long    Car £ Motorcycle £ Skateboard   Hard    Hazel  
Green   Short   House £ Motel                   Soft    Pink  
Red     Hot     Room £ Yard £ Fort £ Castle     Medium  Yellow

产出:

Blue    Long    Car         Hard    Hazel  
Blue    Long    Motorcycle  Hard    Hazel  
Blue    Long    Sketeboard  Hard    Hazel  
Green   Short   House       Soft    Pink  
Green   Short   Motel       Soft    Pink  
Red     Hot     Room        Medium  Yellow  
Red     Hot     Yard        Medium  Yellow  
Red     Hot     Fort        Medium  Yellow  
Red     Hot     Casle       Medium  Yellow

你们的帮助将受到高度赞赏。

Cheers,

页: 1

Answer 1

此处采用的方法将数据按规定分类。法典中使用了变式确定范围,这样,如果需要,就可以改变。

Sub SplitData()
    Dim ws As Worksheet
    Dim rng As Range
    Dim data As Variant
    Dim dataSplit() As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim col As Long, cols As Long
    Dim rws() As String
    Dim addr As String
    Dim rw As Long

    cols = 10   Column J
    col = 4  column D

     Assuming the active shsets contains the data
    Set ws = ActiveSheet

      Assuming data starts in A1 and column A is contiguous
    Set rng = ws.Range(ws.Cells(1, cols), ws.[A1].End(xlDown))

      Get data into an array
    data = rng
    j = 1

      Count number of £ in data
    addr = rng.Columns(col).Address
    rw = Evaluate("=SUM(LEN(" & addr & ")-LEN(SUBSTITUTE(" & addr & ",""£"","""")))")

      Size destination array
    ReDim dataSplit(1 To UBound(data, 1) + rw, 1 To cols)

    For i = 1 To UBound(data, 1)
          if contains £ then split it
        If InStr(data(i, col), "£") > 0 Then
              copy several rows into destination array
            rws = Split(data(i, col), "£")
            For n = 0 To UBound(rws)
                For k = 1 To cols
                    dataSplit(j + n, k) = data(i, k)
                Next
                dataSplit(j + n, col) = Trim(rws(n))
            Next
            j = j + UBound(rws) + 1
        Else
              copy one row into destination array
            For k = 1 To cols
                dataSplit(j, k) = data(i, k)
            Next
            j = j + 1
        End If
    Next

      put resut back into sheet
    rng.Resize(UBound(dataSplit, 1), cols) = dataSplit

End Sub

Answer 2

如果您的初步数据列在A:E栏中,则“C栏”中的“英镑”,则该代码将予以分离,并丢弃给H1室。

You can vary the working range by

changing your initial data layout in this line Range([a1], Cells(Rows.Count, "e").End(xlUp)).Value2 (currently sets A:E)
choose which of the columns to split from range in (1) with this line arrVar = Split(X(lngRow, 3), " £ ") (currently splits the third column)
as per (2) update the column to split in this code line Y(3, lngCnt) = arrVar(lngCol) (currently splits the third column)

sample

Option Base 1
Sub SplitEm()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngCnt As Long
    Dim lngRecord As Long
    Dim X
    Dim Y()
    Dim arrVar() As String

    X = Range([a1], Cells(Rows.Count, "e").End(xlUp)).Value2
     Use a tranposed array to store the results so that the 2nd dimension can be resized very 1000 records
    ReDim Y(5, 1000)

    For lngRow = 1 To UBound(X, 1)
         Split middle column by " £ "
        arrVar = Split(X(lngRow, 3), " £ ")
        For lngCol = LBound(arrVar) To UBound(arrVar)
            lngCnt = lngCnt + 1
             redim storage array if needed
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(5, UBound(Y, 2) + 1000)
             dump 5 new records
               For lngRecord = 1 To UBound(X, 2)
                    Y(lngRecord, lngCnt) = X(lngRow, lngRecord)
            Next
             update record 3 with the split text
            Y(3, lngCnt) = arrVar(lngCol)
        Next lngCol
    Next lngRow
    [h1].Resize(UBound(Y, 2), UBound(Y, 1)).Value2 = Application.Transpose(Y)
End Sub

友情链接