将dynamic单元格中的值复制到特定命名的列

我想将dynamic工作表中的值导入到按列标题sorting的“数据库”中。 正如你所看到的，我已经把一些有用的东西拼凑在了一起，但是它非常缓慢，并且不会复制这些值。 表格的第一行是标题，第二行和下一行是我想要复制的值。

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或直接设置单元格的值，但我无法得到它的工作。 我googling每个错误抛出，然后search错误发生的地方的代码。

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