Question

我正在努力创建执行以下操作的VBA代码：

从源数据集中复制并粘贴值：

以如下所示格式进入新工作簿：

下面的VBA可以很好地将C和D列中交替行中的值粘贴到新工作簿中：

Sub rangeToColumn()

Dim rng As Range
Dim i 'index of cells
Dim f

Set rng = Workbooks("Excel1").Worksheets("SourceSheet").Range("C3:D6")
i = 0
For Each f In rng
    i = i + 1
    Workbooks("Excel2").Worksheets("TargetSheet").Cells(i, 1).Value = f.Value
Next f

End Sub

但是我只是不知道如何进行其余的工作。尝试了多种方法，但均无效果。我基本上需要源中的B3:B6值在目标工作簿的C列中有两次，而对于E3:E6来说则是相同的，只是下面的每一行应该是相反的值。

非常感谢您的帮助。谢谢。

托马斯。

Answer 1

这是一种方法。循环浏览起始范围的每一行，并以此方式引用每个单元格。您需要在工作簿/工作表引用中添加。

Sub x()

Dim r As Range, n As Long, i As Long

Set r = Sheet1.Range("B2", Sheet1.Range("E" & Rows.Count).End(xlUp))

For i = 1 To r.Rows.Count
    n = n + 1
    Sheet2.Cells(n, 1).Value = r.Cells(i, 2).Value
    Sheet2.Cells(n, 3).Value = r.Cells(i, 1).Value
    Sheet2.Cells(n, 6).Value = r.Cells(i, 4).Value
    n = n + 1
    Sheet2.Cells(n, 1).Value = r.Cells(i, 3).Value
    Sheet2.Cells(n, 3).Value = r.Cells(i, 1).Value
    Sheet2.Cells(n, 6).Value = r.Cells(i, 4).Value * -1
Next i

End Sub

开始数据（工作表1）

输出（Sheet2）

Answer 2

您可以尝试：

Option Explicit

 Sub test()

    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim wbNew As Workbook
    Dim LastrowS As Long, LastrowT As Long, i As Long
    Dim Desc As String, BS As Long, PL As Long

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")

    Set wbNew = Workbooks.Add
        Application.DisplayAlerts = False
            wbNew.SaveAs Filename:="C:\Users\XXXXXX\Desktop\New_Workbook_Test.xls"
        Application.DisplayAlerts = True

    Set wsTarget = wbNew.Worksheets("Sheet1")

    LastrowS = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row

        For i = 2 To LastrowS

            Desc = wsSource.Range("B" & i).Value
            BS = wsSource.Range("C" & i).Value
            PL = wsSource.Range("D" & i).Value

            LastrowS = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row

            wsTarget.Range("A" & LastrowS + 1).Value = BS
            wsTarget.Range("C" & LastrowS + 1).Value = Desc
            wsTarget.Range("F" & LastrowS + 1).Value = -Abs(BS)

            wsTarget.Range("A" & LastrowS + 2).Value = PL
            wsTarget.Range("C" & LastrowS + 2).Value = Desc
            wsTarget.Range("F" & LastrowS + 2).Value = -Abs(PL)

        Next i

 End Sub

Answer 3

尝试此代码，您可以对其进行自定义以满足您的需求。

如果您有更多列，只需复制并粘贴以下代码“复制第一列”即可

Sub rangeToColumn()

    ' Define objects
    Dim sourceRange As Range
    Dim sourceCell As Range
    Dim targetCell As Range

    ' Define variables
    Dim sourceWBName As String ' WB = Workbook name
    Dim targetWBName As String

    Dim sourceWSName As String ' WS = Worksheet name
    Dim targetWSName As String

    Dim sourceRangeAddress As String
    Dim targetInitCellAddress As String ' Cell's address

    Dim counter As Integer ' Change for long instead of integer if more than 32000 values

    ' Initialize variables
    sourceWBName = "Book1"
    targetWBName = "Book2"

    sourceWSName = "SourceSheet"
    targetWSName = "TargetSheet"



    ' Copy first column
    sourceRangeAddress = "C2:C5"
    targetInitCellAddress = "A1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell


    ' Copy second column
    sourceRangeAddress = "B2:B5"
    targetInitCellAddress = "C1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell


    ' Copy third column
    sourceRangeAddress = "E2:E5"
    targetInitCellAddress = "F1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell

End Sub

如果有帮助，请标记此答案。

VBA代码可将行从一个工作簿复制和粘贴两次到另一个工作簿

3 个答案: