| |
こんにちは。かみちゃん です。
すでにHirofumiさんからも、コードが提示されていますが、
> ListingDataをF1キーで見ますと、「無効なオブジェクトライブラリーです。または定義されいないオブジェクトへの参照を含んでいます。」と表示されました。
と同じ状況になりました。（WindowsXP HomeEdition + Excel2002）
そこで、私もコードを作ってみました。
汚くて遅いかも？しれませんが、単純な処理で、動作確認はとれています。
ご参考になれば・・・
※転記に失敗したときには、当該セルの隣に「転記失敗」と表示します。
また、処理前に分類シートは値クリアしています。
Option Explicit
'分類シート名格納の変数宣言
Dim Bunrui_SheetName As String
Sub TEST()
Dim rtn As Variant
Bunrui_SheetName = "分類シート"
'分類シートの内容クリア（追加処理する場合はこの１行は不要）
Sheets(Bunrui_SheetName).Range("C9:IV65536").ClearContents
'形式1シートの転記処理（C列より転記）
rtn = CopyValue("形式1シート", 3)
'形式2シートの転記処理（F列より転記）
rtn = CopyValue("形式2シート", 7)
End Sub
'シート転記処理（共通）
Function CopyValue(TargetSheet As String, ColumnNo As Integer)
'転記元シートのＡ列の最終行
Dim LastRow1 As Long
'転記先シートへのキー
Dim Key As String
'添え字
Dim i, RowNo As Long
Dim c As Range
Worksheets(TargetSheet).Activate
'転記元シートのＡ列の最終行の取得（途中の行に空白行がないこと）
LastRow1 = Range("A1").CurrentRegion.Rows.Count
'転記処理
For i = 2 To LastRow1
'転記先のセル位置へのキー取得
Key = Cells(i, 4).Value
'「転記失敗」表示セルの消去
Cells(i, 5).ClearContents
'転記先のセル位置（Ａ列）の検索
With Worksheets(Bunrui_SheetName)
Set c = .Range("A1:A65536").Find(Key, LookIn:=xlValues)
If Not c Is Nothing Then
'転記先のセル位置（行方向）の検索
For RowNo = c.Row To c.Row + 15 - 1
If .Cells(RowNo, ColumnNo) = "" Then Exit For
Next
'転記処理（転記先の列位置は、ColumnNoを参照）
Range(Cells(i, 1), Cells(i, 3)).Copy
Sheets(Bunrui_SheetName).Select
Cells(RowNo, ColumnNo).Select
ActiveSheet.Paste
'転記元シートのコピーモードを解除
Sheets(TargetSheet).Select
Application.CutCopyMode = False
Else
'転記に失敗した場合は、当該データの右隣のセルに記述
Cells(i, 5) = "転記失敗"
End If
End With
Next
End Function
|
|
かみちゃん
- 04/5/1(土) 18:19 -
