[[20170822115013]] 『複数ファイルからの転記(オートシェイプ有無判定』(vvvv) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『複数ファイルからの転記(オートシェイプ有無判定)』(vvvv)

皆様よろしくお願いします。
現在、複数のブックから値を転記するというコードを記述しております。

 2点ほどクリアしたい課題があります。
 1.転記対象シートが複数ある場合
 転記元ファイル(複数 ブック)と転記先ファイルがあるとして、基本的には転記元ファイルの
名前(1)というシートから値を転記したいのですが、ファイルによっては、名前(1)以外に名前(2)、名前(3)というシートも存在し、これらも対象にしたいのです。名前(x)以外にもシートは存在するため、すべてのシートから引っ張るというやり方ではだめです。ちなみに転記対象シートは名前(x)でxが変わるfだけです

2.図形(オートシェイプ)あるなしの判定

 転記には2種類あり、1つは直接値をとる場合(これはクリア済みです)2つ目は
対象座標のセルに図形(楕円)がある場合、その列の6行目の値を取得するというもので、
ここの図形がある場合、ない場合の判定がわかりません。
 図形あるなし転記は、
 列(F,G,H)
 行(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45)
を対象にしております。例えば、10行目G列に図形があったとしたら、6行目G列の値を取得するというものです。
 条件として、
 図形はF,G,Hの内1つの列に図形が存在する場合とどの列にも図形がない場合があります。
ない場合には、対象外という文字を転記先シートに入力したいのです。

 現在のコードでは色のあるなしで判定していましたが、図形で判定したいのです
( If sh2.Range(tbl(k) & j).Interior.ColorIndex <> xlNone Then
 .Cells(i, ctbl(col)).Value = sh2.Range(tbl(k) & 6).Value)

 長くなりましたが、ご協力いただけると幸いです。
 以下に現在のコードを示します。

Sub Sample()

 Dim fpath As String, fname As String
 Dim wb As Workbook
 Dim sh1 As Worksheet, sh2 As Worksheet
 Dim tbl As Variant
 Dim ctbl As Variant
 Dim i As Long, j As Integer
 Dim k As Integer, col As Integer
 Application.ScreenUpdating = False
 tbl = Array("F", "G", "H")
 ctbl = Array(7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45)
 fpath = ThisWorkbook.Path & "\"
 Set sh1 = ThisWorkbook.Worksheets("Sheet1")
 i = 5
 fpath = ThisWorkbook.Path & "\"
 fname = Dir(fpath & "*.xlsx", vbNormal)
 Do Until fname = ""
 If fname <> ThisWorkbook.Name Then
 Set wb = Workbooks.Open(fpath & fname, UpdateLinks:=0)
 Set sh2 = wb.Worksheets("名前 (1)")
 i = i + 1
 With sh1
 .Range("A" & i).Value = sh2.Range("G2").Value
 .Range("B" & i).Value = sh2.Range("G3").Value
 .Range("H" & i).Value = sh2.Range("I3").Value
 .Range("I" & i).Value = sh2.Range("I4").Value
 .Range("J" & i).Value = sh2.Range("I2").Value
 .Range("Q" & i).Value = sh2.Range("J7").Value
 .Range("R" & i).Value = sh2.Range("K7").Value
 .Range("X" & i).Value = sh2.Range("J13").Value
 .Range("AD" & i).Value = sh2.Range("J18").Value
 .Range("AE" & i).Value = sh2.Range("K13").Value
 .Range("AL" & i).Value = sh2.Range("J30").Value
 .Range("AM" & i).Value = sh2.Range("K30").Value
 .Range("AS" & i).Value = sh2.Range("J36").Value
 .Range("AT" & i).Value = sh2.Range("K36").Value
 .Range("AX" & i).Value = sh2.Range("J41").Value
 .Range("AY" & i).Value = sh2.Range("K41").Value
 .Range("BB" & i).Value = sh2.Range("J44").Value
 .Range("BC" & i).Value = sh2.Range("K44").Value
 col = -1
 For j = 7 To 45
 col = col + 1
 If j = 23 Then
 j = 30
 End If
 For k = 0 To 2
 If sh2.Range(tbl(k) & j).Interior.ColorIndex <> xlNone Then
 .Cells(i, ctbl(col)).Value = sh2.Range(tbl(k) & 6).Value
 Exit For
 End If
 Next k
 Next j
 End With
 wb.Close SaveChanges:=False
 End If
 fname = Dir()
 Loop
 Application.ScreenUpdating = True

 End Sub 

< 使用 Excel:Excel2013、使用 OS:Windows7 >


ここまでのコードが書ける方でしたら、以下のコードが参考になるでしょうか?

 Sub test()
    Dim i As Long
    Dim j As Long

    For i = 1 To Sheets.Count
        With Sheets(i)
            If .Name Like "名前 (*)" Then
                For j = 1 To .Shapes.Count
                    Debug.Print .Name, .Shapes(j).Name, .Shapes(j).TopLeftCell.Address(0, 0)
                Next j
            End If
        End With
    Next i
 End Sub
(???) 2017/08/22(火) 12:10

???様

ご返信ありがとうございます。
書き忘れたのですが、このコードの大部分は手伝ってもらったもので、当方初心者です。。。

 Set sh2 = wb.Worksheets("名前 (*)")
ではだめですよね??

あと、図形の判定はShapes.Countで図形の数を集計するのでしょうか?

すみませんが、よろしくお願いします。

(vvvv) 2017/08/22(火) 13:54


シート名は、ワイルドカード指定できません。なので、全シート分ループさせ、Like文で1シートずつワイルドカード利用して判定。 該当するシートだけ処理しています。

また、図形は幾つ貼っているか(貼っていないか)判りませんので、全図形分ループしないといけません。 Countでは、何個図形があるかが判るだけです。 図形があれば、図形がかかっている左上のセルが判るので、セル位置を使って目的の範囲かどうかチェックすれば良いでしょう。(図形の色で判定、とかもできますが、貴方かどういう図形を貼っているのやら、皆目判りませんので、ご自身で応用してみてください)

そして、ご自身で書いたコードでないならば、少なくともそれを書ける方が身近に居るのですから、そちらに相談すべきでしょう。
(???) 2017/08/22(火) 14:07


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.