现在,向我提供要在数据库中使用的电子表格的部门在一个单元格中包含多个文本。 为了链接到该数据,我必须将其分成多行。 示例:LC123 / LC463 / LC9846需要在每一行中复制仅用一个“ LC”字符串复制的整个行-cell1 cell2 LC123 cell1 cell2 LC463 cell1 cell2 LC9846

我尝试了这两个子例程,但显然失败了

Sub InSert_Row()
Dim j As Long
j = InputBox(=SUM(LEN(ActiveCell)-LEN(SUBSTITUTE(ActiveCell,"LC",""))-1)
ActiveCell.EntireRow.Copy
ActiveCell.Offset(j).EntireRow.Insert Shift:=xlDown
End Sub

Sub SplitAndTranspose()
Dim N() As String
N = Split(ActiveCell, Chr(10))
ActiveCell.Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N)
End Sub

第二个子例程将拆分并复制,但不会插入行,而是覆盖其下面的行。

===============>>#1 票数:1 已采纳

记忆中的方法

必要时插入行可能是最容易理解的方法,但是制作成千上万个单独的行插入的性能将不佳。 一次即可(也许只需要一次)就可以了,并且只需要花一两分钟即可运行,但是我想这到底是什么,所以写了一种使用集合和数组拆分内存中数据的方法。 它将以秒为单位运行。

我已经评论了它在做什么。

Sub ProcessData()
    Dim c As Collection
    Dim arr, recordVector
    Dim i As Long, j As Long
    Dim rng As Range
    Dim part, parts

    'replace with your code to assign the right range etc
    Set rng = ActiveSheet.UsedRange
    j = 3 'replace with right column index, or work it out using Range.Find etc

    arr = rng.Value 'load the data

    'Process the data adding additional rows etc
    Set c = New Collection
    For i = 1 To UBound(arr, 1)
        parts = Split(arr(i, j), "/") 'split the data based on "/"
        For Each part In parts 'loop through each "LC" thing
            recordVector = getVector(arr, i) 'get the row data
            recordVector(j) = part 'replace the "LC" thing
            c.Add recordVector 'add it to our results collection
        Next part
    Next i

    'Prepare to dump the data back to the worksheet
    rng.Clear

    With rng.Parent
        .Range( _
            rng.Cells(1, 1), _
            rng.Cells(1, 1).Offset(c.Count - 1, UBound(arr, 2) - 1)) _
            .Value = getCollectionOfVectorsToArray(c)
    End With

End Sub

'Helper method to return a vector representing our row data
Private Function getVector(dataArray, dataRecordIndex As Long)
    Dim j As Long, tmpArr
    ReDim tmpArr(LBound(dataArray, 2) To UBound(dataArray, 2))
    For j = LBound(tmpArr) To UBound(tmpArr)
        tmpArr(j) = dataArray(dataRecordIndex, j)
    Next j
    getVector = tmpArr
End Function
'Helper method to return an array from a collection of vectors
Function getCollectionOfVectorsToArray(c As Collection)
    Dim i As Long, j As Long, arr
    ReDim arr(1 To c.Count, LBound(c(1), 1) To UBound(c(1), 1))
    For i = 1 To c.Count
        For j = LBound(arr, 2) To UBound(arr, 2)
            arr(i, j) = c(i)(j)
        Next j
    Next i
    getCollectionOfVectorsToArray = arr
End Function

编辑:

替代的“范围插入”方法。

它将较慢(尽管我使离散插入和复制操作的数量基于原始行数,而不是基于某些递归扫描,因此也不太糟),但更易于理解,因此可以根据需要进行调整。 它应在几分钟内运行。

Sub ProcessData_RangeMethod()
    Dim rng As Range
    Dim colIndex As Long
    Dim parts
    Dim currRowIndex As Long

    'replace with your code to assign the right range etc
    Set rng = ActiveSheet.UsedRange

    colIndex = 3 'replace with right column index, or work it out using Range.Find etc

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    currRowIndex = 1
    Do Until currRowIndex > rng.Rows.Count
        parts = Split(rng.Cells(currRowIndex, colIndex), "/")
        If UBound(parts) > 0 Then
            rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)).Insert xlShiftDown
            rng.Rows(currRowIndex).Copy rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count))
            rng.Range(rng.Cells(currRowIndex, colIndex), rng.Cells(currRowIndex + UBound(parts), colIndex)).Value = Application.Transpose(parts)
        End If
        currRowIndex = currRowIndex + 1 + UBound(parts)
    Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

  ask by user13597 translate from so

未解决问题?本站智能推荐:

1回复

单元格公式内的VBA部分字符串CountIf(不是值)

因此,我有一个工作表,其中有一堆链接单元格设置为UNC路径。 例如,假设单元格A1等于: 并且单元格A2等于: 有没有办法为整个工作表的部分字符串“ CountOver”设置CountIf? 它将返回2。 这就是我正在使用的内容,但它始终返回0,因为我认为它仅查看值。
3回复

如果相邻单元格值与列名称匹配,Excel VBA将在列下插入行

我在工作表OrderForm有一个OrderForm ,在工作表OrderData中有一个表OrderTable ,如下所示: 现在,一个customerID可以以一种形式提交的最大产品编号为3,该列表来自productlist的数据验证。 我的目标是每次提交OrderForm ,
1回复

Excel VBA在工作表上找到具有特定值(字符串)的单元格

我需要在工作表上查找文本值并从那里向下偏移两行的帮助。 我有一个带有“范围底部”标题的单元格。 下方的两个单元格为实际值。 问题是“范围底部”可能在7个可能的位置,具体取决于工作表模板。 如何找到其中包含“范围底部”的单元格? 然后,我可以.Offset(2,0).value2
2回复

如何在Excel VBA中将单元格从一行复制到另一行

我只想将数据从A7复制到F2; B7 TO F3和C7至F4在同一张纸上。 我使用了上面的代码。 但是,如果我要再增加一行(即A18 B18 C18),则它行不通。 帮我
1回复

删除单元格中文本字符串中具有特定编号的行

我有一个包含约500个数据条目的列表,其中一些在单元格中具有相同编号的不同文本。 我需要找到所有带有“ 00000”的行并将其删除。 我需要计算“ test2”开始无法工作的时间(18:23),并且需要知道重新工作需要多长时间(18:30),并且error00000消息使我的公式弄乱了,所以
1回复

VBA:将单元格区域复制到其他工作簿

我目前正在处理一组集成的工作簿,需要在工作簿之间传输数据值。 为此,我需要一个VBA宏,该宏可以复制特定范围(工作表中的一行)并将其插入另一本书的概述列表的底部。 我怎样才能做到这一点? 我是VBA的新手,因此请务必提供具体说明。 注意:我使用的是MS Excel 2010。
2回复

复制单元格内容-Excel 2010 VBA

我正在尝试完成一个相对(我认为)简单的任务。 我想创建一个将活动单元格的内容复制到剪贴板的按钮。 然后,我将使用crtl + v粘贴到另一个应用程序中。 目的是在Excel工作表内复制一串文本...包括格式和换行符。 我想避免必须按F2,Crtl + shift + home,然后再按c
3回复

查找给定字符串的单元格列

我试图找到包含字符串“状态”的单元格的列。 该单元格位于另一个名为“ Report”的工作表中,我不知道该单元格在哪里; 我只确切知道其中包含什么。 我只需要知道单元格所在的列。我该如何做(在VBA中)? 任何帮助将不胜感激! 到目前为止,我的代码如下:
1回复

根据单元格中的文本字符串筛选数据透视表

我有以下代码: 因此,您可以看到我正在尝试根据K2中的值更改数据透视表,但始终收到错误“运行时错误'1004':无法设置PivotField类的CurrentPage属性”并调试突出显示的行“ Field.CurrentPage = NewCat”。 对于为什么以及如何使此代码起作
2回复

如何检测字符串中单元格中是否存在单词?

我有一些代码正在研究需要检测某个单元格中是否包含特定单词的地方,如果有,它将在相邻单元格中插入一个特定的字符串。 但是,在执行检测部分时遇到了问题! 到目前为止,这就是我所拥有的。 我将在这里剪下重要部分。 我的意图是,这将在单元格(i,7)中的字符串中搜索单词Cylinde