首页 文章

在excel中使用VBA在循环中转换单元格

提问于
浏览 次
-1

我正在尝试从一张纸（行）中复制单元格并将它们粘贴到另一张纸上（基本上将其转置） . 我编写了代码，但无法绕过粘贴单元格和pastespecial命令 . 复制单元格的长度因每行而异，那么如何动态选择并粘贴相同的方式呢？截至目前，我正在考虑粘贴特定长度并删除末尾的空白行 . 请参阅下面的代码 . 如果有人能给我一个输入或想法，那将是很棒的 . 谢谢！！

Sub Data_Sort_Test()

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long
Dim rng As Range, row As Range, rowd1 As Range, cell As Range
Dim bidtype As String
k = 1
lastrow1 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).row

For i = 1 To lastrow1
bidtype = Sheets("Sheet2").Cells(i, "A").Value 

Sheets("Sheet1").Activate
lastrow2 = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).row

For j = 1 To lastrow2
If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then

Sheets("Sheet2").Activate
Sheets("Sheet2").Range(Cells(i, "B"), Cells(i, "K")).Copy
Sheets("Sheet3").Activate
Sheets("Sheet3").Range(Cells(j, "C"), Cells(j, "L")).Select
ActiveSheet.Paste 'Special Transpose:=True
'k = k + 1
End If
Next j
Application.CutCopyMode = False
Next i

End Sub
excel-vba copy-paste vba excel

2 回答

  • 0

    试试这个，让我知道它是否有效：

    Sub Data_Sort_Test()

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long
Dim rng As Range, row As Range, rowd1 As Range, cell As Range
Dim bidtype As String
Dim tWs As Worksheet

Set tWs = Sheets("Sheet3")
With Sheets("Sheet2")
k = 1
lastrow1 = .Range("A" & .Rows.Count).End(xlUp).row

For i = 1 To lastrow1
    bidtype = .Cells(i, "A").Value

    lastrow2 = Sheets("Sheet1").Range("B" & Sheets("Sheet1").Rows.Count).End(xlUp).row
    For j = 1 To lastrow2
        If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then

            .Range(.Cells(i, "B"), .Cells(i, "K")).Copy

            tWs.Range(tWs.Cells(j, "C"), tWs.Cells(j, "L")).PasteSpecial 'Transpose:=True

        End If
    Next j
    Application.CutCopyMode = False
Next i
End with
End Sub

    我删除了所有 .Select 和 .Activate 并直接用适当的父母替换它们 . 这将加快代码速度并使其更易于阅读 .

    回复于
  • 1

    @Scott我已经把转置，但不知何故rows.count有问题 . 你怎么看？？

    Sub Data_Sort_Test()

Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long
Dim rng As Range, row As Range, rowd1 As Range, cell As Range
Dim bidtype As String
Dim tWs As Worksheet

Set tWs = Sheets("Sheet3")
With Sheets("Sheet2")
k = 1
lastrow1 = .Range("A" & .Rows.Count).End(xlUp).row

For i = 1 To lastrow1
bidtype = .Cells(i, "A").Value

lastrow2 = Sheets("Sheet1").Range("B" & **strong text**Sheets("Sheet1").Rows.Count).End(xlUp).row
For j = 1 To lastrow2
    If Sheets("Sheet1").Cells(j, "B").Value = bidtype Then

        .Range(.Cells(i, "B"), .Cells(i, "K")).Copy

        tWs.Range("B" & Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        tWs.Range("B1").Delete shift:=xlUp

    End If
Next j
Application.CutCopyMode = False
Next i
End With
End Sub
    回复于

相关问题