0

これを機能させることができないようです。どこに問題があるのか​​ わかりません。

それはうまくコンパイルされますが、私のシートでは何もしません。列ヘッダーでデータをコピーし、同じヘッダーを持つ同じワークブック内の別のテンプレート シートに貼り付けるマクロを作成しようとしています。

たとえば、インポート シートの「開始時間」列のデータをコピーし、新しいデータをコピーして、メイン シートの「開始時間」列に貼り付けます。 

Sub CopyByHeader()

Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo

Set shtImport = ActiveSheet ' "import" - could be different workbook
Set shtMain = ThisWorkbook.Sheets("Main")

For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
    'only copy if >1 value in this column (ie. not just the header)
    If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
        Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
        LookAt:=xlWhole)
        If Not f Is Nothing Then
            Set rngCopy = shtImport.Range(c.Offset(1, 0), _
                shtImport.Cells(Rows.Count, c.Column).End(xlUp))
            Set rngCopyTo = shtMain.Cells(Rows.Count, _
                f.Column).End(xlUp).Offset(1, 0)
            'copy values
            rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
        End If
    End If
 Next c

 End Sub

私はこれに変更しましたが、これは非常に遅いです...何か考えはありますか??:

Sub ImportTimeStudy()
Dim myHeaders, e, x, wsImport As Worksheet, wsMain As Worksheet
Dim r As Range, c As Range

myHeaders = Array(Array("Time Started", "Time Started"), Array("Description of the task", "Description of the task"), Array("Level", "Level"), Array("Location", "Location"), Array("Targeted", "Targeted"), Array("System", "System"), Array("Process Code", "Process Code"), _
            Array("Value Stream", "Value Stream"), Array("Subject", "Subject"), Array("BU", "BU"), Array("Task Duration", "Task Duration"), Array("Activity Code", "Activity Code"))

Set wsImport = Sheets("Import")
Set wsMain = Sheets("Main")

For Each e In myHeaders

    Set r = wsImport.Cells.Find(e(0), , , xlWhole)

    If Not r Is Nothing Then
        Set c = wsMain.Cells.Find(e(1), , , xlWhole)

        If Not c Is Nothing Then
            wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
            wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
        Else
            msg = msg & vbLf & e(1) & " " & wsMain.Name
        End If
    Else
        msg = msg & vbLf & e(0) & " " & wsImport.Name
    End If

Next

If Len(msg) Then
    MsgBox "Header not found" & msg

End If

Application.ScreenUpdating = False

End Sub
4

1 に答える 1

3

私はあなたのループを2つのループに書き直しましforた、これを試してみてください:(インラインでコメント）

Sub CopyByHeader()


Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ActiveSheet ' "import" - could be different workbook
Set shtMain = ThisWorkbook.Sheets("Main")

Dim lCopyColumn As Long
Dim lCopyRow As Long
Dim lLastRowOfColumn As Long

'- for each column in row 1 of import sheet
For lCopyColumn = 1 To shtImport.Cells(1, shtImport.Columns.Count).End(xlToLeft).Column
    '- check what the last row is with data in column
    lLastRowOfColumn = shtImport.Cells(shtImport.Rows.Count, lCopyColumn).End(xlUp).Row

    'if last row was larger than one then we will loop through rows and copy
    If lLastRowOfColumn > 1 Then
        For lCopyRow = 1 To lLastRowOfColumn
            '- note we are copying to the corresponding cell address, this can be modified.
            shtMain.Cells(lCopyRow, lCopyColumn).Value = shtImport.Cells(lCopyRow, lCopyColumn).Value
        Next lCopyRow
    End If
Next lCopyColumn

End Sub
于 2012-09-18T17:30:22.723 に答える