Excel VBA質問箱 IV

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

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


10064 / 13646 ツリー ←次へ | 前へ→

【23886】開かれていない別のブックのシートの追加 okb 05/4/6(水) 14:15 質問[未読]
【23889】Re:開かれていない別のブックのシートの... okb 05/4/6(水) 16:18 質問[未読]
【23904】Re:開かれていない別のブックのシートの... Hirofumi 05/4/6(水) 22:01 発言[未読]
【23905】Re:開かれていない別のブックのシートの... okb 05/4/7(木) 0:01 お礼[未読]
【23926】Re:開かれていない別のブックのシートの... Hirofumi 05/4/7(木) 19:00 回答[未読]
【23927】Re:開かれていない別のブックのシートの... Hirofumi 05/4/7(木) 19:18 回答[未読]
【23929】Re:開かれていない別のブックのシートの... okb 05/4/7(木) 23:33 お礼[未読]

【23886】開かれていない別のブックのシートの追加
質問  okb  - 05/4/6(水) 14:15 -

引用なし
パスワード
   http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=23850;id=excelで、投稿して解決したと思ったのですが、ダメでした。
処理方法を次のように変えました。
コピーされる側から、コピー元のブックを開いて、コピー元の1つのシートを
指定して、シートを追加後、コピー元のブックを閉じるというものです。
マクロは、次のとおりなんですがインデックスが、有効範囲にないエラーになります。
また、オープン時ファイルがない旨のエラーになります。

Sub シートの追加()
  Dim Bookname As String
  Dim I As Long, j As Long
  Dim Shname As String
  With ThisWorkbook.Worksheets("Menu")
         コピーされる側です。
    For j = 4 To 10 Step 3
      For I = 5 To 29 Step 2
        If .Cells(I, j).Value <> "" And .Cells(I, j - 1).Value <> "" Then
          Shname = Trim(.Cells(I, j - 1).Value)
          Exit For
        End If
      Next I
    Next j
  End With
  Bookname = "設備点検.xls"
        コピー元です。
  Fname = Range("O29").Value & Bookname
  MsgBox Fname
        C:\FreeSoft\000EXCEL\設備点検.xlsと表示されます。
  'Workbooks.Open Filename:=Fname
        これでオープンするとファイル見つからないとなります。
        下では、正常にオープンできるのになぜなんでしょうか?
  Workbooks.Open Filename:="C:\FreeSoft\000EXCEL\設備点検.xls"
  MsgBox Workbooks(Bookname).Name
        設備点検.xlsと表示されます 
  MsgBox Shname
        指定のシート名が表示されます
  MsgBox ThisWorkbook.Name
        コピーされる側のブック名を表示がされます 
  Workbooks(Bookname).Worksheets(Shname).Copy After:=ThisWorkbook.Sheets("Menu")
        ここでインデクスエラーとなるのですが、なぜなんでしょうか?
  Workbooks(Bookname).Saved = True
  Workbooks(Bookname).Close
End Sub

以上、よろしくお願いします。

【23889】Re:開かれていない別のブックのシートの...
質問  okb  - 05/4/6(水) 16:18 -

引用なし
パスワード
   原因が判ってきました。
説明不測だったのですが、シート"Menu"から取得するShnameは、ハイパーリンクで取り込んだもので Workbooks(Bookname).Worksheets(Shname)が、認識されないようです。
Shnameの値によっては正常に処理できます。
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=23756;id=excelで、
Hirofumiさんに、対応していただき解決したのと同じですね。
と考え、となりのセルにコピーしたセルから取得できるように、
If .Cells(I, j).Value <> "" And .Cells(I, j - 1).Value <> "" Then
          Shname = Trim(.Cells(I, j - 1).Value
これを
If .Cells(I, j).Value <> "" And .Cells(I, j + 1).Value <> "" Then
          Shname = Trim(.Cells(I, j + 1).Value)
としたのですが、ダメでした。
どうも、値によって正常に処理できるときと出来ないときがあるようです。
たとえば、
非常コンセント、スプリンクラー  は不可
点検結果、消火器、泡、動力ポンプ は正常
どう対応すればいいんでしょうか?

【23904】Re:開かれていない別のブックのシートの...
発言  Hirofumi  - 05/4/6(水) 22:01 -

引用なし
パスワード
   >これでオープンするとファイル見つからないとなります。
をまずTestしてみます
新規のBookの標準モジュールに以下のコードを記述します
Pathの有る(Range("O29")の有る)、BookをOpenしてActiveにします
VBAEditor上でイミディエイトウィンドウを表示して以下のコードを実行します
文字を1つづつ比較し違いが有れば、イミディエイトウィンドウに表示します

Public Sub Test1()

  Const cstrGoodPath As String = "C:\FreeSoft\000EXCEL\設備点検.xls"
  
  Dim i As Long
  Dim strFilename As String
  Dim strNoGoodPath As String
  Dim blnNoMatch As Boolean
  Dim strNoGood As String
  Dim strGood As String
  Dim strType1 As String
  Dim strType2 As String
  
  strNoGoodPath = ActiveWorkbook.Worksheets("Menu").Range("O29").Value & "設備点検.xls"
  
  If Len(strNoGoodPath) <> Len(cstrGoodPath) Then
    Debug.Print "文字数が違います"
    Debug.Print "NoGood = " & Len(strNoGood), "Good = " & Len(cstrGoodPath)
    Debug.Print
  End If
  
  For i = 1 To Len(strNoGoodPath)
    strNoGood = Mid(strNoGoodPath, i, 1)
    If 0 <= Asc(strNoGood) And Asc(strNoGood) <= 255 Then
      strType1 = "半角"
    Else
      strType1 = "全角"
    End If
    strGood = Mid(cstrGoodPath, i, 1)
    If 0 <= Asc(strGood) And Asc(strGood) <= 255 Then
      strType2 = "半角"
    Else
      strType2 = "全角"
    End If
    If strNoGood <> strGood Then
      Debug.Print "NoGood = "; strNoGood, strType1, _
            "Good = "; strGood, strType2
      blnNoMatch = True
    End If
  Next i
  
  If Not blnNoMatch Then
    Debug.Print "全て同じ文字です"
  End If
  
End Sub

次に、以下のコードの"MenuBook.xls"を"Menu"の有るBook名に変更して
「"Menu"の有るBook」と「設備点検.xls」を開き
Test2を実行するとマクロの有るBookのSheet1に、Shnameのに取り出されるシート名と
「設備点検.xls」の該当するシート名が上下に出力されますので、見比べてください
尚、スペースを確認する為、名前の前後に*が付きます

Public Sub Test2()

  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim vntData() As Variant
  Dim vntName() As Variant
  Dim wksMark As Worksheet
  
  With Workbooks("MenuBook.xls").Worksheets("Menu")
    For j = 4 To 10 Step 3
      For i = 5 To 29 Step 2
        If .Cells(i, j).Value <> "" And .Cells(i, j - 1).Value <> "" Then
          ReDim Preserve vntData(k)
          vntData(k) = .Cells(i, j - 1).Value
          k = k + 1
        End If
      Next i
    Next j
  End With
  
  k = 0
  With Workbooks("設備点検.xls")
    For i = 0 To UBound(vntData)
      For Each wksMark In .Worksheets
        If StrComp(Trim(wksMark.Name), _
            Trim(vntData(i)), vbTextCompare) = 0 Then
          ReDim Preserve vntName(k)
          vntName(k) = wksMark.Name
          k = k + 1
          Exit For
        End If
      Next wksMark
    Next i
  End With
  
  For i = 0 To UBound(vntData)
    vntData(i) = "*" & vntData(i) & "*"
  Next i
  For i = 0 To UBound(vntName)
    vntData(i) = "*" & vntName(i) & "*"
  Next i
  
  With ThisWorkbook.Worksheets("Sheet1")
    .Cells(1, "A").Resize(, UBound(vntData) + 1).Value = vntData
    .Cells(2, "A").Resize(, UBound(vntName) + 1).Value = vntName
  End With
  
End Sub

【23905】Re:開かれていない別のブックのシートの...
お礼  okb  - 05/4/7(木) 0:01 -

引用なし
パスワード
   Hirufumiさん、お手数かけて申し訳ないです。
まず、ファイルパスの件ですが,Range("O29")を書き換えたら、正常に動作しました。作っていただいたソースは、文字列比較ツールとして利用させていただきます。すみません。

次に、シート名の件ですが、30枚ほどのシートのうち正常に動作しなかったのは
4件でしたので、シート名を変更したらうまくいきました。
スプリンクラー→Sprinkler
非常電源(自家)→非常電源 自家
非常電源(蓄電)→非常電源 蓄電
非常電源(専用)→非常電源 蓄電
うまくいった、理由はわかりません。
その理由をTest2()を実行して調べるため、Sprinklerをスプリンクラーに
戻して実行すると、正常に動作し再現できませんでした。
Test2()を実行したら、同じシート名が表示されます。(1行目は*つき)
なぜなんでしょうね?もし心当たりがあれば、投稿ねがいます。

それにしても、Horofumiさんには、ご面倒をかけ申し訳ないです。
ありがとうございました。

【23926】Re:開かれていない別のブックのシートの...
回答  Hirofumi  - 05/4/7(木) 19:00 -

引用なし
パスワード
   >Test2()を実行したら、同じシート名が表示されます。(1行目は*つき)
>なぜなんでしょうね?もし心当たりがあれば、投稿ねがいます。
>

ゴメン、急いで書いたのでバグって居ました
  
  For i = 0 To UBound(vntData)
    vntData(i) = "*" & vntData(i) & "*"
  Next i
  For i = 0 To UBound(vntName)
    vntData(i) = "*" & vntName(i) & "*"
  Next i

この部分を以下の様に修正して下さい
  
  For i = 0 To UBound(vntData)
    vntData(i) = "*" & vntData(i) & "*"
  Next i
  For i = 0 To UBound(vntName)
    vntName(i) = "*" & vntName(i) & "*"
  Next i

此れは、何をしようとしているのかと言うと
Test2の結果は、2行に成り
上の行は"Menu"のシートのセルに書かれているシート名
下の行は、"設備点検.xls"のシートで、"Menu"のシートのセルの値とvbTextCompare
の比較で合致したシート名で、上下段とも、セルの値の前後に"*"を付けて表示しています
StrComp関数のvbTextCompareの比較と言うのは、
同じ文字の全角、半角、大文字、小文字は全て同じ文字と見なされます
詰まり、上下段を見比べて何が違っているのか見て下さいと言う意味でUpした物です
一寸見で、解らない物でも、全角、半角が違っている等はよく有る事なので?
また、最悪、StrComp関数のvbTextCompareの比較で上手く行くなら遅く成りますが
此れをFunctionにして、セルの値をちゃんとしたシート名に変換して、其の値を使って
シートを指定すれば善いかと思います

 

【23927】Re:開かれていない別のブックのシートの...
回答  Hirofumi  - 05/4/7(木) 19:18 -

引用なし
パスワード
   上手くいくかどうか解りませんがコードにするとこんな

Sub シートの追加()

  Dim Bookname As String
  Dim i As Long, j As Long
  Dim Shname As String
  Dim Fname As String
  Dim wkbDestination As Workbook
  
  With ThisWorkbook.Worksheets("Menu")
'         コピーされる側です。
    For j = 4 To 10 Step 3
      For i = 5 To 29 Step 2
        If .Cells(i, j).Value <> "" And .Cells(i, j - 1).Value <> "" Then
          Shname = Trim(.Cells(i, j - 1).Value)
          Exit For
        End If
      Next i
    Next j
  End With

  Bookname = "設備点検.xls"
'        コピー元です。
  Fname = Range("O29").Value & Bookname
  Set wkbDestination = Workbooks.Open(FileName:=Fname)
  Shname = GetSheetsName(Shname, wkbDestination)
  With wkbDestination
    If Shname <> "" Then
      .Worksheets(Shname).Copy After:=ThisWorkbook.Sheets("Menu")
      .Saved = True
    Else
      Beep
      MsgBox "該当するシートが有りません"
    End If
    .Close
  End With
  
  Set wkbDestination = Nothing
  
End Sub

Private Function GetSheetsName(strName As String, _
                wkbMark As Workbook) As String
  Dim wksMark As Worksheet
  
  For Each wksMark In wkbMark.Worksheets
    If StrComp(Trim(wksMark.Name), _
        Trim(strName), vbTextCompare) = 0 Then
      GetSheetsName = wksMark.Name
      Exit For
    End If
  Next wksMark
  
  Set wksMark = Nothing
  
End Function

【23929】Re:開かれていない別のブックのシートの...
お礼  okb  - 05/4/7(木) 23:33 -

引用なし
パスワード
   ご丁寧に、レスありがとうございます。
シートの処理方法、大変参考になります。
取り込んで、活用させてもらいます。

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