1

我有一个格式大致如下的数据集：

.../DATA/...
猫/1763/9.4+5.6/Happy
.../DATA/...

我要做的是用连接的数字坐在列中并将它们分开；9.4 和 5.6 并在所有其他数据相同的情况下创建彼此相邻的两行：

.../DATA/...
猫/1763/9.4/Happy
Cats/1763/5.6/Happy
.../DATA/...

经历几千行并不是所有的都被连接起来。

我已经做了一些尝试，但是尽管各个组件似乎都可以工作（在不抛出语法错误的意义上），但整个都没有。有任何想法吗？

主要功能是“plusinsert”，它从下拉表中获取一个字符串来定位特定的工作表。它是从各种论坛片段拼凑而成的，希望我能相信原作者，但我没有得到名字。

Sub CopyR()
Dim cl As Range
Dim r As Long
Set cl = ActiveCell
r = cl.Row
Range("a" & r, Range("CQ" & r)).Copy

End Sub  


Function Extractparts(path As String)
Dim parts

parts = Split(path, "+")
Extract1 = parts(1)
Extract2 = parts(2)
End Function  
Public Sub plusinsert(name As String)

Dim Target2, cell As Range
Dim cellvalue As String

ActiveWorkbook.Sheets(name).Activate
Set Target2 = ActiveSheet.Range(Range("G1"), Range("D65536").End(xlUp))

For Each cell In Target2
If cell.CountIf(cell, "*+*") Then
cellvalue = cell.Value:
Extractparts (cellvalue):
CopyR:
ActiveSheet.Paste:
Application.CutCopyMode = False:
cell.Value = Extract1:
cell.Offset(1, 0).Value = Extract2
Next cell

End Sub

使用列中的数据，我使用以下代码解决了这个问题：

Dim Target, cell, RowRange As Range
Dim cellvalue As String
Dim Count As Integer
' Snippet target range, is for whole column in production.
Set Target = Range("G2:G8")  

Dim TestArray() As String  

For Each cell In Target
  TestArray() = Split(cell.Value, "+"):
  cell.Value = TestArray(0)
  If UBound(TestArray) > 0 Then
  Set RowRange = cell.EntireRow:
  RowRange.Copy:
  RowRange.Insert Shift:=xlUp:
  Application.CutCopyMode = False:
  cell.Value = TestArray(1)
End If
Next cell
4

1 回答 1

0

注意» 注释掉的部分，您可以在其中调整您的Column、firstDataRow和deli设置delim假设

您的数据全部放在列中A；您的工作表如下所示：
开始
您运行此代码

Option Explicit

Sub SplitingAndInserting()

    Dim ws As Worksheet, rng As Range
    Dim i&, deli$, delim$, urColumn$, firstDataRow&

    ' setters
    ' modify them if you need to
    Set ws = Sheets("Sheet1")
    urColumn = "A"
    firstDataRow = 1
    deli = "+"
    delim = "/"

    For i = ws.Range(urColumn & Rows.Count).End(xlUp).Row To firstDataRow Step -1
        Set rng = ws.Range(urColumn & i)
        If InStr(1, rng.Value, deli, vbTextCompare) Then
            Dim var As Variant
            var = Split(rng.Value, deli)
            If UBound(var) > 0 Then
                ws.Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown
                Dim j&
                Dim fpart As String
                fpart = var(0)
                Dim spart As String
                spart = var(1)
                For j = 1 To Len(spart)
                    If StrComp(delim, Left(Right(spart, j), 1), vbTextCompare) = 0 Then
                        fpart = fpart + Right(spart, j)
                        Exit For
                    End If
                Next j
                rng = fpart
                fpart = var(0)
                For j = 1 To Len(fpart)
                    If StrComp(delim, Left(Right(fpart, j), 1), vbTextCompare) = 0 Then
                        spart = Left(fpart, Len(fpart) - (j - 1)) & spart
                        Exit For
                    End If
                Next j
                rng.Offset(1, 0) = spart
            End If
        End If
        Set rng = Nothing
    Next i

End Sub


得到这样的结果：
结束

于 2013-07-01T15:59:05.617 回答