Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7159 / 13645 ツリー ←次へ | 前へ→

【40743】検索にかけ転記したいのですが。 toy 06/7/22(土) 1:11 質問[未読]
【40756】Re:検索にかけ転記したいのですが。 ナイスプログラム 06/7/23(日) 2:20 回答[未読]
【40769】Re:検索にかけ転記したいのですが。 toy 06/7/23(日) 16:44 発言[未読]
【40771】Re:検索にかけ転記したいのですが。 ナイスプログラム 06/7/23(日) 19:49 回答[未読]
【40773】Re:検索にかけ転記したいのですが。 ナイスプログラム 06/7/23(日) 21:27 回答[未読]
【40824】Re:検索にかけ転記したいのですが。 toy 06/7/24(月) 19:56 お礼[未読]
【40757】Re:検索にかけ転記したいのですが。 kobasan 06/7/23(日) 9:13 発言[未読]

【40743】検索にかけ転記したいのですが。
質問  toy  - 06/7/22(土) 1:11 -

引用なし
パスワード
   こんにちは。
検索について教えてください!

フォルダの中にファイルが現在5つあります。
ファイル名は製造番号11、製造番号22・・・製造番号55とあり、
それぞれ販売期間が違います。
たとえば製造番号11は4月〜6月、製造番号22は5〜7月・・です。
またその月ごとに売上が書かれていて

製造番号11の詳細シート
A        B    C    D     E  F・・・・ M
製造番号11   4 月   5 月   6 月           
東京本店    15000  12000   13000
大阪支店    13000  15000  12000

製造番号22の詳細シート
A        B    C    D     E  F・・・・M
製造番号22   5 月   6 月   7月             
東京本店    15000  11000   13000
大阪支店    14000  15000  11000


この情報を別のフォルダに入っている"予算"ブックの"売上"シートに下記のように合計を転記したいと思っております。


  A    B    C    D    E    F   G   H   I
製造番号 4月   5月  6月   7月   8月 9月 10月 11月・・・
11    28000  27000  25000
22        29000  26000  24000
33
44
55

Sub 検索()
  Dim status As Range
  
  Set status = Workbooks("詳細表").Worksheets("詳細").Range("B2:M2"). _
    Find(what:="4月", lookat:=xlWhole)
   If Not status Is Nothing Then
   status.Select
   Workbooks("予算").Worksheets("売上").Range("B2") = _
      (Selection.Offset(1).Value + Selection.Offset(2).Value)
   Else
   Worksheets("売上").Range("B2") = "0"
   End If
End Sub


"詳細"シートB2:M2の行から4月を探し出し、4月が見つかればその下2つの値を足した合計を、予算ブックの売上シート"B2"に転記させ、4月がなければ0の値を入れようと
コードを書いてみましたが、データが見つかりませんというエラーが出ます。
同じブック内だと作動したのですが、ブックが違うとだめなんでしょうか?
もしくはfindではなく何か違う方法はございますでしょうか?
ご助言よろしくお願いします。

【40756】Re:検索にかけ転記したいのですが。
回答  ナイスプログラム WEB  - 06/7/23(日) 2:20 -

引用なし
パスワード
    今晩は。

 私は、単純に、ループで値を比較する方法を良く使います。
また、それぞれの詳細シートを2次元配列に代入してから、
売上シートに記入していく方法も良く使います。
この方法だと、アドレスの指定が簡単なので、割と短いコードで出来ます。

【40757】Re:検索にかけ転記したいのですが。
発言  kobasan  - 06/7/23(日) 9:13 -

引用なし
パスワード
   おはようございます。

Sheet1
> A        B    C    D     E  F・・・・ M
>製造番号11   4 月   5 月   6 月           
>東京本店    15000  12000   13000
>大阪支店    13000  15000  12000


Sheet2
> A        B    C    D     E  F・・・・M
>製造番号22   5 月   6 月   7月             
>東京本店    15000  11000   13000
>大阪支店    14000  15000  11000


Sheet1とSheet2の合計を転記
Sheet3
>  A    B    C    D    E    F   G   H   I
>製造番号 4月   5月  6月   7月   8月 9月 10月 11月・・・
>11    28000  27000  25000
>22        29000  26000  24000
>33
>44
>55

まずは、上記のように、同じブック内で、Sheet3の形を作ってみてはどうでしょうか。
これがでたら、Wprkbooks.Openを利用して、ブック間操作をすればできます。

参考までに、各シートの下に合計を求めるサンプルを作っておきました。
これから先は、いろいろ試してみて、作ってください。

ただし、
A1セルに製造番号○○と必ず入れておいてください。
製造番号11   4 月   5 月   6 月 
の項目行は1行目とします。

Sub test()
Dim nmb As String
Dim s As Worksheet
Dim vntM, myArray(1 To 13)
Dim r As Range, rng As Range
Dim LastRow As Long, clmn As Long
  '
  vntM = Array("製造番号", "4月", "5月", "6月", "7月", "8月", _
      "9月", "10月", "11月", "12月", "1月", "2月", "3月")
  '
  For Each s In ThisWorkbook.Worksheets
    nmb = s.Cells(1, 1).Text
    If Left(nmb, 4) = "製造番号" Then
      LastRow = s.Cells(65536, 1).End(xlUp).Row
      For Each r In s.Range("B1:M1")
        For clmn = 1 To UBound(vntM)
          If vntM(clmn) = r.Text Then Exit For
        Next
        '
        Set rng = r.Offset(1).Resize(LastRow - 1, 1)
        myArray(clmn + 1) = Application.Sum(rng)
      Next
      s.Activate
      s.Cells(LastRow + 2, 1).Resize(2, UBound(myArray)).Value = _
      Application.Transpose(Application.Transpose(Array(vntM, myArray)))
    End If
  Next
  '
  Set rng = Nothing
  Erase vntM: Erase myArray
End Sub

【40769】Re:検索にかけ転記したいのですが。
発言  toy  - 06/7/23(日) 16:44 -

引用なし
パスワード
   ▼ナイスプログラム さん:
こんにちは。ご回答ありがとうございます。

>私は、単純に、ループで値を比較する方法を良く使います。
また、それぞれの詳細シートを2次元配列に代入してから、
売上シートに記入していく方法も良く使います。
この方法だと、アドレスの指定が簡単なので、割と短いコードで出来ます。


申し訳ないのですが
もう少しだけ詳しい解説をお願いしてもよろしいでしょうか?
ループで値を比較?詳細シートを2次元配列に代入?
能力不足で理解できませんでした。
よろしくお願いいたします。

【40771】Re:検索にかけ転記したいのですが。
回答  ナイスプログラム WEB  - 06/7/23(日) 19:49 -

引用なし
パスワード
    今晩は。

 ループで値を比較するとは、たとえば”4月”がvariant型2次元配列vv1(2,1)に入れてあって,"11"がinteger型 ixに入れてあれば、それを予算ブックのrange("b2:l2")とrange("a2:a6")の全ての値と比較する、ということです。たとえば製造番号11の4月のトータルが2次元配列vv11(2,2)に入れてあるとして、

Dim rr as range,r as range
dim ix as integer,ir as integer,ic as integer

set rr=range("b2:l2")
for each r in rr
  if r.value=vv1(2,1) then ir=r.column
next

set rr=range("a2:a6")
for each r in rr
  if r.value=s then ir=r.row
next

cells(ir,ic).value=vv11(2,2)
    
こんな感じです。

シートに書かれた値は、そのままvariant型2次元配列に簡単に代入出来ます。
たとえば

vv11 = Workbooks("詳細表11").Worksheets("詳細").usedRange.value
と書けば、表がそのまま配列になるので、

for i=3 to ubound(vv11,1)
  vv11(2,2)=vv11(2,2)+vv11(i,2)
next

とすれば、vv11(2,2)に、4月のトータルが代入されます。これの2重ループで
各月のトータルを出す訳です。

言葉で説明するのは結構難しいので、後でコードで書いて見ます。

【40773】Re:検索にかけ転記したいのですが。
回答  ナイスプログラム WEB  - 06/7/23(日) 21:27 -

引用なし
パスワード
    今晩は。やって見ました。

 
 値は完全に一致させないと合わないのでご注意下さい。たとえば、
”4月”と”4月”は、合いません。詳細シートの項目を売上シートに
コピーすれば確実です。売上シートの製造番号は数値として扱っています。
これがもし文字列だったらうまく行きません。テストして見て下さい。


Option Explicit
Option Base 1

Const sb1 As String = "詳細11" 'ブックの名称をここに書く。
Const sb2 As String = "詳細22"
Const sb3 As String = "詳細33"
Const sb4 As String = "詳細44"
Const sb5 As String = "詳細55"

Dim ss(5) As String
Dim sinki As Object
Dim vv As Variant
Dim b As Boolean

Sub 詳細記入()

b = False

Call 配列記入(sb1)
Call 配列記入(sb2)
'Call 配列記入(sb3)
'Call 配列記入(sb4)
'Call 配列記入(sb5)


End Sub

Private Sub 配列記入(s1 As String)

Dim i As Integer, j As Integer

Workbooks.Open ThisWorkbook.Path & "\" & s1 & ".xls"
vv = Workbooks(s1 & ".xls").Worksheets(1).UsedRange.Value
vv(1, 1) = Val(Mid(vv(1, 1), 5, Len(vv(1, 1))))

For j = 2 To UBound(vv, 2)
  For i = 3 To UBound(vv, 1)
    vv(2, j) = vv(2, j) + vv(i, j)
  Next
Next

用紙記入

End Sub

Private Sub 用紙記入()

Dim r As Range, rr1 As Range, rr2 As Range
Dim i As Integer, j As Integer, ir As Integer, ix As Integer

If b = False Then
  ThisWorkbook.Worksheets("売上").Copy
  Set sinki = ActiveWorkbook
  b = True
End If

With sinki.Worksheets("売上")
  For i = 2 To 6
    If .Cells(i, 1).Value = vv(1, 1) Then
      ir = i
      Exit For
    End If
  Next
  
  For i = 2 To UBound(vv, 2)
    For j = 2 To 13
      If .Cells(1, j).Value = vv(1, i) Then
        .Cells(ir, j).Value = vv(2, i)
      End If
    Next
  Next
End With
    

End Sub

【40824】Re:検索にかけ転記したいのですが。
お礼  toy  - 06/7/24(月) 19:56 -

引用なし
パスワード
   ▼ナイスプログラム さん:
▼kobasan さん:

ご丁寧にありがとうございました!!
完成しました!

7159 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free