时间戳

首页 > 解决方案 > 根据每行第一个单元格中的选择将一长串数据传输到特定工作表

excel - 根据每行第一个单元格中的选择将一长串数据传输到特定工作表

问题描述

我正在尝试通过在同一个工作簿中添加新行来自动化要传输到特定工作表的数据列表。

理想情况下，我不想限制要传输的数据行数，因为可能会有大量数据进入。我尝试了以下代码，但它仅适用于单行数据，任何人都可以帮助改进此代码传输多行？

Sub AddValues()

'Dimension variable and declare data type
Dim i As Single

'Save row number of cell below last nonempty cell

i = Worksheets("" & Range("A2")).Range("B" & Rows.Count).End(xlUp).Row + 1

'Save input values to selected worksheet

Worksheets("" & Range("A2")).Range("B" & i & ":P" & i) = _
Worksheets("Form").Range("B2:P10").Value

'Clear input cells

Worksheets("Form").Range("B2:P10") = ""

'Stop macro

End Sub

我希望它做的示例输出：

样本

标签： excelvba

解决方案

试试这个：

已编辑。那是最后一个版本，修复了上一个版本的转移问题。我只是添加了一些评论，以便将来您可以轻松修改它。

Option Explicit

Sub AddValues()

'Dimension variable and declare data type
Dim i As Long 'Counter
Dim j As Long 'Counter
Dim NextRow As Long 'Last Row used

'Save input values to selected worksheet
For i = 2 To Worksheets("Form").UsedRange.SpecialCells(xlCellTypeLastCell).Row 'For Each Row on Sheet "Form"

'If there is no item still copied (Problem with merged cells)

    If Worksheets(Range("A" & i).Value2).Cells(1048576, 2).End(xlUp).Row < 7 Then
        For j = 2 To Worksheets("Form").UsedRange.SpecialCells(xlCellTypeLastCell).Column
            Worksheets(Range("A" & i).Value2).Cells(7, j).Value2 = Worksheets("Form").Cells(i, j).Value2
        Next j

'If there is just one item still copied (Problem with merged cells)

    ElseIf Worksheets(Range("A" & i).Value2).Cells(1048576, 2).End(xlUp).Row = 7 Then
        For j = 2 To Worksheets("Form").UsedRange.SpecialCells(xlCellTypeLastCell).Column
            Worksheets(Range("A" & i).Value2).Cells(8, j).Value2 = Worksheets("Form").Cells(i, j).Value2
        Next j

'For all remaining scenarios

    Else
        NextRow = Worksheets(Range("A" & i).Value2).Cells(1048576, 2).End(xlUp).Row
        For j = 2 To Worksheets("Form").UsedRange.SpecialCells(xlCellTypeLastCell).Column
            Worksheets(Range("A" & i).Value2).Cells(NextRow + 1, j).Value2 = Worksheets("Form").Cells(i, j).Value2
        Next j
    End If

Next i

'Clear input cells from B2 cell until the last Cell (not required to pay attention to the range)

Range(Cells(2, 2), Worksheets("Form").UsedRange.SpecialCells(xlCellTypeLastCell)) = ""

'End macro


End Sub

希望能帮助到你！

推荐阅读