ダイナミックセルから特定の名前の列に値をコピーする

Question

動的ワークシートの値を列のタイトルでソートされた「データベース」にインポートします。あなたが見ることができるように、私は働くものを掻き集めましたが、それは非常に遅く、値だけをコピーしません。 シートの最初の行はタイトルで、2番目の行とさらに下の行はコピーしたい値です。

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