Question

我想将动态工作表中的值导入我们的数据库＆＃34;按列标题排序。正如你所看到的，我已经把一些有效的东西拼凑在了一起，但它很慢并且不会复制这些值。工作表的第一行是标题，第二行和更下面的行是我想要复制的值。

Sub Copypasta()

    Sheets("copypasta").Select
    Sheets("copypasta").Range("A2").Activate
    While Not ActiveSheet.Cells(1, ActiveCell.Column) = ""
        t1 = ActiveSheet.Cells(1, ActiveCell.Column)
        Selection.Copy
        Set MyActiveCell = ActiveCell
        Sheets("Database").Activate
        lnCol = Sheets("Database").Cells(1, 1).EntireRow.Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
        lnRow = Sheets("Database").Range("a65536").End(xlUp).Row
        If lnCol > 1 Then Sheets("Database").Cells(lnRow, lnCol).Activate Else Sheets("Database").Cells(lnRow, lnCol).Offset(1, 0).Activate
        ActiveSheet.Paste 'xlPasteValues
        Sheets("copypasta").Activate
        MyActiveCell.Offset(0, 1).Activate
    Wend

End Sub

我尝试使用PasteSpecial xlPasteValues或直接设置单元格的值，但我无法使其工作。我正在搜索它抛出的每个错误，然后在代码中搜索错误发生的位置。

Answer 1

尝试以下代码：

Option Explicit

Sub Copypasta()

Dim CopySht As Worksheet
Dim DBSht As Worksheet
Dim i As Long, lnCol As Long, lnRow As Long
Dim MyActiveCell As Range, FindRng As Range
Dim t1

' set the Worksheet objects
Set CopySht = ThisWorkbook.Sheets("copypasta")
Set DBSht = ThisWorkbook.Sheets("Database")

' set the anchor position on the loop
Set MyActiveCell = CopySht.Range("A2")

' loop through columns at the first row (until you reach a column that is empty)
While CopySht.Cells(1, MyActiveCell.Column) <> ""
    t1 = CopySht.Cells(1, MyActiveCell.Column)
    MyActiveCell.Copy

    With DBSht
        lnRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' find last row with data in Column "A"

        Set FindRng = .Rows(1).Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        If Not FindRng Is Nothing Then ' check if Find was successful
            lnCol = FindRng.Column
        Else
            lnCol = 1
        End If

         ' there's no need to use Select and Activate to Copy and/or Paste
        .Cells(lnRow + 1, lnCol).PasteSpecial xlPasteValues
    End With

    Set MyActiveCell = MyActiveCell.Offset(0, 1) ' loop one column to the right
Wend

End Sub

将值从动态单元格复制到特定命名的列

1 个答案: