| |
みなさん、こんにちは。以前にも私の質問に対して、快くご回答していただいた方ありがとうございました。また今回も分からないことがあり、投稿させていただきました。標題のとおり、検索したデータを特定のシートへ貼り付ける、という作業なのですが、考えているとおり、うまくいきません。具体的には、次のとおりの作業で、その次に考えたコードをのせています。もちろん、このコードでは何ら反応しません。まだ、初心者で四苦八苦しながらやっているのですが、どうしてもわからいので、どうかお力を貸してください。宜しくお願いします。
1.シート１にデータがあります。データの内容は次のとおりです。
これらのデータは毎日、シート１へ貼り付けられます。
従いまして、B列の日付けデータ・A列の店名・B〜G列の数字は
毎日、違います。又、グループ数（各日にちのデータをいいます）も違います。 ちなみに、1・2行は文字列が入っていますので省略させていただきます。
A B C D E F G
1
2
3 20040401
4 貸分 借分 貸借合計
5 件数 金額 件数 金額 件数 金額
6 A店 2 1,000 5 6,500 7 7,500
7 B店 3 2,000 3 2,000 6 4,000
8 合計 5 3,000 8 8,500 13 11,500
9 20040402
10 貸分 借分 貸借合計
11 A店 1 1,000 5 6,500 6 7,500
12 D店 3 2,000 3 2,000 6 4,000
13 G店 2 1,000 5 6,500 7 7,500
14 合計 6 4,000 13 15,000 19 19,000
15 ・
16 ・
2.D列の借分の件数・金額を、B列の日付データを検索条件として、1日〜31日分のシートにある表のセルE1と合致するシートを検索し、貼り付けます。店数は全部で33店あります。
その表は以下のとおりです。
（4月1日分の場合）
B E Q R
1 20040401
2
3
4 件数 金額
5 A店
6 B店
7 C店
8 D店
9 E店
10 F店
・
・
37 AG店
3.モジュールです。この内容では、セルB3の日付分のデータだけしか検索することができません。これをシート1のB列の全ての日付分のデータを検索し、対象となる日付シートへ貼り付けたいのです。なお、前述でもふれましたが、店数が多いことから、以下のようなコードですと、かなりのコードを入力しなくてはなりません。
このことから、もっと省略できるようなコードがありましたら、併せて、ご教授をお願いいたします。
Sub 日計表へ移行()
Dim i As Integer
Dim 行番号 As Long
Dim 列番号 As Long
Dim 選択シート() As Variant
Dim 検索文字 As String
Dim 合致セル As Range
Dim 日付 As Range
Application.ScreenUpdating = false
Worksheets("シート1").Select
'グループ1.について日計表へ移行させる。
ReDim 選択シート(31)
検索文字 = Range("B3").Value
’シートを検索する。
For i = 5 To 35
Set 合致セル = Worksheets(i).Cells(1, 5).Find(検索文字,
LookIn:=xlValues, lookat:=xlPart)
If Not 合致セル Is Nothing Then
If 選択シート(1) = "" Then
選択シート(1) = i
End If
End If
Next i
’当月分のデータではない時、メッセージをだす。
If 選択シート(1) = "" Then
MsgBox "グループ1.については、他の月の分です。"
Else
行番号 = 3
列番号 = 1
For 行番号 = 3 To 65536 Step 1
If Cells(行番号, 列番号) = "" And Cells(行番号, 列番号 + 1)
= "" Then
Exit For
End If
If Cells(行番号, 列番号) = "A店" Then
Cells(行番号, 列番号 + 3).Copy
Worksheets(選択シート(1)).Select
Range("Q5").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
Paste:=xlPasteValues
Application.CutCopyMode = False
Worksheets("シート1").Select
Cells(行番号, 列番号 + 4).Copy
Worksheets(選択シート(1)).Select
Range("R5").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
Paste:=xlPasteValues
Application.CutCopyMode = False
ElseIf Cells(行番号, 列番号) = "B支店" Then
Worksheets("シート1").Select
Cells(行番号, 列番号 + 3).Copy
Worksheets(選択シート(1)).Select
Range("Q6").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
Paste:=xlPasteValues
Application.CutCopyMode = False
Worksheets("シート1").Select
Cells(行番号, 列番号 + 4).Copy
Worksheets(選択シート(1)).Select
Range("R6").PasteSpecial OPERATION:=xlPasteSpecialOperationAdd, _
Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next
End If
Application.ScreenUpdating = True
End Sub
|
|
ハルコ
- 04/5/8(土) 15:29 -
