Question

在不使用select或active的情况下，我正在尝试在Sheet1中复制两行中的名称，并在sheet2中垂直粘贴名称，并对此新列表进行排序。

所以我写了这段代码：

Sub CopyData()
  List1 = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
  List2 = Worksheets("Sheet1").Cells(36, Columns.Count).End(xlToLeft).Column

  Worksheets("Sheet1").Range("B2", Cells(2, List1)).copy
  Worksheets("Sheet2").Range("B3").PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False, Transpose:=True

  Worksheets("Sheet1").Range("B36", Cells(36, List2)).copy
  Worksheets("Sheet2").Cells(List1, 2).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False, Transpose:=True

  Worksheets("Sheet2").Range("B2", Cells(List1 + List2, 2)).Sort Key1:=Range("B2"), Order1:=xlAscending, _
    Order2:=xlYes, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End sub

我使用List1和List2变量来了解这两行的名称，以便我可以将它们组合成Sheet2中的一个。

如果我在Sheet1中，代码的复制和粘贴部分单独工作，如果我在Sheet2中，单独的代码的排序部分也可以工作，但是当我合并两个代码时它不起作用，所以问题必须是我需要引用工作表或变量，但我似乎无法做到这一点，有人可以帮助我。

Answer 1

这是将一张纸上的两个不同行上的数据复制到另一张纸上的单个列的一种方法。无论你在哪张纸上，它都应该有效。

顺便说一句，请注意，既不使用选择也不激活。

Option Explicit
Sub CopyData()
  Dim WS1 As Worksheet, WS2 As Worksheet
  Dim rSortRange As Range
  Set WS1 = Worksheets("sheet1")
  Set WS2 = Worksheets("sheet2")
  WS2.Cells.Clear
    With WS1
        .Range("b2", .Cells(2, .Columns.Count).End(xlToLeft)).Copy
    End With
    WS2.Range("b3").PasteSpecial Paste:=xlPasteValues, skipblanks:=False, Transpose:=True

    With WS1
        .Range("b36", .Cells(36, .Columns.Count).End(xlToLeft)).Copy
    End With

    With WS2
        .Range("b3").End(xlDown).Offset(rowoffset:=1).PasteSpecial Paste:=xlPasteValues, skipblanks:=False, Transpose:=True
        Set rSortRange = .Range("B3", .Cells(Rows.Count, "B").End(xlUp))
        rSortRange.Sort key1:=rSortRange, order1:=xlAscending, Header:=xlNo
        .Range("b3").EntireColumn.AutoFit
    End With
    Application.CutCopyMode = False

End Sub

如果您希望复制其他行或更多行而不仅仅是两行，这里有一个更通用的例程，允许您输入多行来复制/转置/粘贴。

此外，由于您正在排序，我选择将skipblanks参数更改为True。无论如何，这些空白都将排在最后。

Option Explicit
Sub CopyData()
  Dim WS1 As Worksheet, WS2 As Worksheet
  Dim rDest As Range
  Dim rSortRange As Range
  Dim aRows As Variant
  Dim I As Long

  Set WS1 = Worksheets("sheet1")
  Set WS2 = Worksheets("sheet2")

Application.ScreenUpdating = False

  Set rDest = WS2.Range("B3")
  rDest.EntireColumn.Clear

  aRows = Array(2, 36) 'Rows to copy

For I = LBound(aRows) To UBound(aRows)
    With WS1
            .Range(.Cells(aRows(I), 2), .Cells(aRows(I), .Columns.Count).End(xlToLeft)).Copy
    End With
    rDest.PasteSpecial Paste:=xlPasteValues, skipblanks:=True, Transpose:=True
    Set rDest = WS2.Cells(WS2.Rows.Count, rDest.Column).End(xlUp).Offset(rowoffset:=1)
Next I

With WS2
    Set rSortRange = .Range("B3", .Cells(Rows.Count, "B").End(xlUp))
    rSortRange.Sort key1:=rSortRange, order1:=xlAscending, Header:=xlNo
    .Range("b3").EntireColumn.AutoFit
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Answer 2

我是证明，在我写这篇文章的时间里，有人可能已经回答了你的问题，但是这里我是如何编写代码的。请不要苛刻，我还在学习，所以我发现尝试回答这些问题有助于我变得更好。

Sub CopyData()

    'Application.ScreenUpdating = False                       'Optional
    'Application.Calculation = xlCalculationManual            'Optional

    Dim lROW1 As String
    Dim lROW2 As String

    'This will find the last row incase it changes often
    lROW1 = Sheets("Sheet1").Range("X65000").End(xlUp).Row   'Replace X for your First list Column Letter
    lROW2 = Sheets("Sheet1").Range("X65000").End(xlUp).Row   'Replace X for your Second list Column Letter

    Sheets("Sheet1").Select
    Range("XX:X" & lROW1).Select                             'Replace XX:X with your first Column Letter and Row Number, replace X with the Column Letter (IE: A1:A)
    Selection Copy

    Sheets("Sheet2").Select
    Range("XX").Select                                       'Replace XX with the Address where you want the data pasted
    Selection.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False


    Sheets("Sheet1").Select
    Range("XX:X" & lROW2).Select                             'Replace XX:X with your Second Column Letter and Row Number, replace X with the Column Letter (IE: A1:A)
    Selection Copy

    Sheets("Sheet2").Select
    Range("XX").Select                                       'Replace XX with the Address where you want the data pasted
    Selection.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

    'Application.ScreenUpdating = True                       'Optional
    'Application.Calculation = xlCalculationAutomatic        'Optional

End Sub

将名称列表复制并粘贴到不同的工作表并对其进行排序

2 个答案: