Question

我使用下面的代码将我的数据从一张纸复制到另一张。

Sub Copypastemeddata()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim sourceCell As Range
    Dim targetSheet As Worksheet
    Dim StartRow As Integer

    Application.ScreenUpdating = False
    Application.CopyObjectsWithCells = False

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Opgørsel")
    Set sourceCell = ws.Range("D3")  'Cell with sheet names for copying to
    StartRow = 1    'Destination row on targetSheet
    With ws
          Set targetSheet = wb.Worksheets(sourceCell.Text)
         .Range("A1").CurrentRegion.Copy
         targetSheet.Range("A" & StartRow).Insert Shift:=xlDown
         targetSheet.Columns.AutoFit
    End With

    Application.CutCopyMode = 0
    Application.ScreenUpdating = True
    Application.CopyObjectsWithCells = True
End Sub

在我正在复制的工作表中，我希望每次单元格“tykkelse [m]”下的值不同时插入一行，如果多个副本的值相同，则将其划分到同一行。

感谢。

Answer 1

下面的

提供了一个可能的解决方案：

Sub solved()

Set findfirst = Sheet1.Range("H:H").Find("tykkelse [m]")

currentvalue = findfirst.Offset(1, 0).Value

findfirst.Offset(-1, 0).EntireRow.Insert xlDown
With Range(Cells(findfirst.Row - 2, 1), Cells(findfirst.Row - 2, 14))
    .Merge
    .Value = currentvalue
End With

Set findfirst = Sheet1.Range("H:H").Find("tykkelse [m]")
Set findsecond = Sheet1.Range("H:H").FindNext(After:=findfirst)

Do While Intersect(findsecond, findfirst) Is Nothing

    If findsecond.Offset(1, 0).Value <> currentvalue Then
        currentvalue = findsecond.Offset(1, 0).Value
        findsecond.Offset(-1, 0).EntireRow.Insert xlDown
        With Range(Cells(findsecond.Row - 2, 1), Cells(findsecond.Row - 2, 14))
            .Merge
            .Value = currentvalue
        End With
    End If

    Set findsecond = Sheet1.Range("H:H").FindNext(findsecond)

Loop

End Sub

首先，我们发现第一次出现“tykkelse [m]”：

然后我们存储与此事件关联的值，并插入上面的行并合并（仍然要添加颜色和对齐）

我们再次发现第一次出现，因为它已经转移，我们需要它进行下面的检查。我们遍历H列中的每一个事件，并通过将它与第一个匹配项进行比较来检查它们是否全部。

对于每次出现，我们检查下面的值是否已经改变;如果是这样，我们应用相同的操作。

VBA - 如何插入行并将数据分组？

1 个答案: