[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ファイルからの転記(オートシェイプ有無判定)』(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
また、図形は幾つ貼っているか(貼っていないか)判りませんので、全図形分ループしないといけません。 Countでは、何個図形があるかが判るだけです。 図形があれば、図形がかかっている左上のセルが判るので、セル位置を使って目的の範囲かどうかチェックすれば良いでしょう。(図形の色で判定、とかもできますが、貴方かどういう図形を貼っているのやら、皆目判りませんので、ご自身で応用してみてください)
そして、ご自身で書いたコードでないならば、少なくともそれを書ける方が身近に居るのですから、そちらに相談すべきでしょう。
(???) 2017/08/22(火) 14:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.