循环行以从一个 sheet 的列复制到另一个 sheet 的列

Question

我需要使用来自一个 sheet 的数据来填写同一工作簿中的另一个 sheet。

使用 sheet1 的数据：

C 列的项目将被复制到 Sheet2，所有相关信息也将被复制。
然后 D 列的项目及其相关信息将被复制到下一行。
这将重复进行，直到 Sheet1 中的所有行都被复制到 Sheet2 中。

（注意：我将这个宏作为按钮放在另一个 sheet 中，所以我在我的代码中引用了每个 sheet。）

      NumRows = Worksheets("Sheet1").Range("C2", Range("C2").End(xlDown)).Rows.Count
      ' Select cell, *first line of data*.
      Worksheets("Sheet1").Range("C2").Select
      ' Set Do loop to stop when ten consecutive empty cells are reached. (Make sure it's safely run; ignore)
      j = 4
      Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(10, 0))
         For i = 2 To NumRows
            j = j + 1
            Worksheets("Sheet1").Cells(i, "C").Value = Worksheets("Sheet2").Cells(j, "C").Value
        Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
        Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
        Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
            ' New row for next item
        j = j + 1
            Worksheets("Sheet1").Cells(i, "D").Value = Worksheets("Sheet2").Cells(j, "C").Value
        Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
        Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
        Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
      Next
      Loop
    Application.ScreenUpdating = True
End Sub

Answer 1

您的代码正在从 sheet2 复制到 sheet1。

Option Explicit

Sub Macro1()

    Dim j As Long, i As Long, c As Long
    Dim ws2 As Worksheet, lastrow As Long
    Set ws2 = Sheets("Sheet2")
    j = 1
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
        For i = 2 To lastrow
            For c = 3 To 4
                If Len(.Cells(i, c)) > 0 Then
                    j = j + 1
                    ws2.Cells(j, "A") = .Cells(i, "A")
                    ws2.Cells(j, "B") = .Cells(i, "B")
                    ws2.Cells(j, "C") = .Cells(i, c)
                    ws2.Cells(j, "D") = .Cells(i, "E")
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox j-1 & " rows copied", vbInformation
    
End Sub

Answer 2

逆透视数据

标题说明了一切：这是 Power Query 的工作。然而，这是我对 VBA.

Option Explicit

Sub UnpivotData()
    Const ProcTitle As String = "Unpivot Data"
    
    Const sName As String = "Sheet1"
    Dim ssCols As Variant: ssCols = VBA.Array(1, 2, 5)
    Dim smCols As Variant: smCols = VBA.Array(3, 4)
    
    Const dName As String = "Sheet2"
    Const dFirst As String = "A2"
    Dim dsCols As Variant: dsCols = VBA.Array(1, 2, 4)
    Const dmCol As Long = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = strg.Rows.Count - 1 ' no headers
    Dim sdrg As Range: Set sdrg = strg.Resize(srCount).Offset(1)
    Dim sdData As Variant: sdData = sdrg.Value
    
    Dim drCount As Long: drCount = srCount * (UBound(smCols) + 1)
    Dim dcCount As Long: dcCount = UBound(dsCols) + 2
    Dim ddData As Variant: ReDim ddData(1 To drCount, 1 To dcCount)
    
    Dim sdValue As Variant
    Dim sr As Long
    Dim sc As Long
    Dim c As Long
    Dim dr As Long
    
    For sr = 1 To srCount
        For sc = 0 To UBound(smCols)
            sdValue = sdData(sr, smCols(sc))
            If Not IsError(sdValue) Then
                If Len(CStr(sdValue)) > 0 Then
                    dr = dr + 1
                    ddData(dr, dmCol) = sdValue
                    For c = 0 To UBound(ssCols)
                        ddData(dr, dsCols(c)) = sdData(sr, ssCols(c))
                    Next c
                'Else ' blank value
                End If
            'Else ' error value
            End If
        Next sc
    Next sr
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim ddrg As Range: Set ddrg = dfCell.Resize(dr, dcCount)
    ddrg.Value = ddData
    
    MsgBox "Data copied.", vbInformation, ProcTitle
    
End Sub

Answer 3

我相信你想将数据从 sheet1 复制到 sheet2，沿着 sheet 行复制到数据，不确定是否要覆盖 sheet 上的数据to，我们可以创建脚本而不循环，如果有帮助请在下面找到。

Sub Copydata()

Dim I As Long

Sheet1.Select
I = Range("C10000").End(xlUp).Row

Range("C2:C" & I).Select
Range(Selection, Selection.End(xlToRight)).Copy
Sheet2.Select
Range("C10000").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial

End Sub

循环行以从一个 sheet 的列复制到另一个 sheet 的列

Loop rows to copy from one sheet's columns to another sheet

excel

vba

unpivot

逆透视数据