Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2013)
複数ファイルからの転記(オートシェイプ有無判定)
投稿日時: 17/08/22 14:27:15
投稿者: abcdeee

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

回答
投稿日時: 17/08/22 16:49:17
投稿者: Suzu

For Each 〜 を使い、全表示ワークブックの、全シート名を取得する。
 
 Dim wbk As WorkBook
 Dim wst As WorkSheet
 
 For Each wbk In Excel.WorkBooks
   Debug.Print wbk.Name
   For Each wst In wbk.WorkSheets
     Deug.Print vbTab & wst.Name
   Next
 Next wbk
 
その中で、ワークシート名を
『転記対象シートは名前(x)でxが変わるfだけです 』の条件に合致するか判定し
合致すれば、必要な処理を進めましょう。
 
 
Shapeのセルの位置を取得したいのでしょうか。
左上のセル位置を取得し、Shapeの名前と共に、セルの位置をR1C1形式にてMsgBox表示
 
 Dim shp As Shape
 
 For Each shp In ActiveSheet.Shapes
     MsgBox shp.Name & vbCrLf & shp.TopLeftCell.Row & vbTab & shp.TopLeftCell.Column
 Next

回答
投稿日時: 17/08/22 16:58:48
投稿者: WinArrow
投稿者のウェブサイトに移動

図形は、セルには属しているわけではないので、
特定のセルのアドレスをキーにして図形を探すのではなく、
図形の方から、
特定のセルの上にある/ないを判定します。
↓サンプルで検討してみて下さい。
 
 
セルD3上の図形を探すサンプル
 
Sub test()
Dim Shape As Shape
    With ActiveSheet
        For Each Shape In .Shapes
            If Shape.TopLeftCell.Address(0, 0) = "D3" Then
                MsgBox Shape.Name & "は、セルD3の上にある図形です。"
                Exit For
            End If
        Next
    End With
 
End Sub

投稿日時: 17/08/22 17:18:01
投稿者: abcdeee

ありがとうございます。
 下記のように変更したところ
 
nextで指定されたKの参照が不正です。とエラーが出ました。
どこを直したらよいのでしょうか?
 
col = -1
 For j = 7 To 45
 col = col + 1
 If j = 23 Then
 j = 30
 End If
 For k = 0 To 2
 
 For Each Shape In .Shapes
 If Shape.TopLeftCell.Address(0, 0) = "sh2.Range(tbl(k) & j)" 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

回答
投稿日時: 17/08/22 17:53:29
投稿者: WinArrow
投稿者のウェブサイトに移動

最初に
 
コードはインデントをキチンとつけましょう。
 
ところで

引用:
col = -1
  For j = 7 To 45
  col = col + 1
  If j = 23 Then
  j = 30
  End If

↑は、何をしているんですか?
文章で説明してください。
 
 
>If Shape.TopLeftCell.Address(0, 0) = "sh2.Range(tbl(k) & j)" Then

"sh2.Range(tbl(k) & j)"
全部が文字列となりますから、何時まで経っても条件は成り立ちませんよ。
 
sh2.Range(tbl(k) & j).Address(0,0)
にしないとね・・・・

回答
投稿日時: 17/08/22 18:09:36
投稿者: WinArrow
投稿者のウェブサイトに移動

 For Each Shape In .Shapes
に対する
Next Shape
が存在しないよ

回答
投稿日時: 17/08/22 18:18:15
投稿者: WinArrow
投稿者のウェブサイトに移動

以下に、途中からだけでど、インデントを付けた記述を書きます。
コードの内容は変更してありません。
 
    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
 

回答
投稿日時: 17/08/22 18:28:58
投稿者: WinArrow
投稿者のウェブサイトに移動

「名前 (x)」のシート名だけを班別するコードの例
 
Dim sht As Worksheet
    For Each sht In ThisWorkbook.Sheets
        If sht.Name Like "名前 (?)" Then
            Debug.Print sht.Name
        End If
    Next

回答
投稿日時: 17/08/22 18:44:18
投稿者: WinArrow
投稿者のウェブサイトに移動

質問
 
>ctbl = Array(7, 8, 9, 10, 11, 12, 13, 14〜〜〜
は、列番号ですよね?
 
> .Range("H" & i).Value = sh2.Range("I3").Value
> .Range("I" & i).Value = sh2.Range("I4").Value
> .Range("J" & i).Value = sh2.Range("I2").Value
 
とダブっていませんか?
 
一寸見なので、誤解しているかも?

回答
投稿日時: 17/08/22 20:26:18
投稿者: WinArrow
投稿者のウェブサイトに移動

「名前 (X)」を判断するコード修正です。
 
Dim sht As Worksheet
    For Each sht In ThisWorkbook.Sheets
        If Replace(StrConv(sht.Name, vbNarrow), " ", "") Like "名前(*)" Then
            Debug.Print sht.Name
        End If
    Next
 
「名前 (10)」のように、xが2桁以上の場合を考慮

回答
投稿日時: 17/08/23 08:44:13
投稿者: WinArrow
投稿者のウェブサイトに移動

考え方の一例
 
図形があるセルを「行」「列」で、2次元配列化し、ループ検索を止める方法を提案します。
分かり訳すするために「他ブック」からの転送する処理をGOSUB化してあります。
なお、テストはしていませんので、試してみてください。
 
 
Option Explicit
 
Sub test()
Dim wb As Workbook
Dim sht As Worksheet, shape As shape
Dim fname As String
Dim mysht As Worksheet, myRow As Long
Dim shapeTBL, i As Long, j As Long
 
    ReDim shapeTBL(1 To 45, 1 To 8) As Long
    For i = 7 To 45
        For j = 6 To 8
            If Not (i >= 23 And i < 30) Then
                shapeTBL(i, j) = 1
            Else
                shapeTBL(i, j) = 0
            End If
        Next j
    Next i
 
    Set mysht = ThisWorkbook.Sheets("Sheet1")
    With mysht
        myRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
    End With
    Application.ScreenUpdating = False
    fname = Dir(ThisWorkbook.Path & "\*.xlsx")
    Do Until fname = ""
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & fname)
         
        For Each sht In wb.Sheets
            If Replace(StrConv(sht.Name, vbNarrow), " ", "") Like "名前(*)" Then
                GoSub TENSO1 '転送1
                For Each shape In sht.Shapes
                    With shape.TopLeftCell
                        If .Row <= 45 And .Column < 9 Then
                            If shapeTBL(.Row, .Column) = 1 Then
                                GoSub TENSO2 '転送2
                            End If
                        End If
                    End With
                Next shape
            End If
        Next sht
        wb.Close False
        fname = Dir()
    Loop
    Application.ScreenUpdating = True
    Exit Sub
     
TENSO1:
     
    Return
     
TENSO2:
 
    Return
 
End Sub

回答
投稿日時: 17/08/23 09:03:42
投稿者: WinArrow
投稿者のウェブサイトに移動

参考コード修正
 

引用:

With mysht
    myRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
End With

の部分は、
Gosub TENSO1
の前に移動してください。

回答
投稿日時: 17/08/23 21:18:18
投稿者: simple

横から失礼します。
 
あえて申し上げます。
以前にマルチポストについて注意があり、
> ご回答ありがとうございます。
> マルチポストの件、申し訳ございませんでした。
> 向こうは解決済みにしました。
とあなたは書いていますよね。
 
にもかかわらず、また今回も
http://www.excel.studio-kazu.jp/kw/20170822115013.html
とマルチポストしていますね。
 
両方の掲示板ともに、マルチを明示的に禁止はしていませんが、
どちらかの回答は無駄になる可能性が高いですね。
マルチポストが禁止される理由のひとつに、そうしたことがあります。
せっかく手間を掛けた回答が報われません。
 
マルチポストが許されていても、
関連スレッドにきちんと挨拶すべきです。
そういう手間を惜しんでサボるなら、最初からマルチポストはやめてください。
 
--------------
また、こちらの掲示板に限っても
質問者さんが建てたスレッドに、放置状態のものが目立ちます。
http://www.moug.net/faq/search.php?search_author=abcdeee
 
もう少し、まともな利用の仕方をしてもらいたいですね。

投稿日時: 17/08/24 09:13:51
投稿者: abcdeee

こちらを解決済みにします