1321110707 EXCEL VBAについて質問です。良い回答は500~1000ptを差し上げます。

下記のソースでは[大型]シートだけですが、ファイル内に[中型]シート[小型]シートがあり、
大型シートに対象製品が無かったら、中型シートにと順番に調べたいと思っております。
また、対象製品があったら、そこでそのファイルの検索を終了して、次の県のファイルにと
順次値を取得したいです。

ソースでの回答をお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/11/13 00:11:49
  • 終了:2011/11/14 23:04:44

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/11/13 03:08:28

ポイント1000pt

前段の部分が良く見えませんが、Dir 以降をこんな形にしてどうでしょうか。

Sub japan_nan()

     :
     :
     :

    Dim wb As Workbook
    Dim fileName
    fileName = Dir(p & "\" & "*.xls", vbNormal)
    Do While fileName <> ""
        Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
        mySearch wb, Split(fileName, "・")(1) '// ***・県名・*** から県名を取得
        wb.Close
        fileName = Dir
    Loop
End Sub

Sub mySearch(srcWB As Workbook, prefName)
    Dim productName As String
    Dim wsName
    Dim dstWS As Worksheet
    Dim dstRow As Range
    Dim r As Long
    For Each wsName In Array("大型", "中型", "小型")
        With srcWB.Worksheets(wsName)
            For r = 4 To Rows.Count
                productName = StrConv(.Cells(r, "D"), vbWide)
                If productName = "" Then Exit For
                
                On Error Resume Next
                Set dstWS = ThisWorkbook.Worksheets(productName)
                On Error GoTo 0
                
                If Not dstWS Is Nothing Then
                    dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    dstWS.Cells(dstRow, "B").Value = prefName
                    dstWS.Cells(dstRow, "C").Value = productName
                    dstWS.Cells(dstRow, "G").Value = .Range("J2")
                    dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
                    Exit Sub
                End If
            Next
        End With
    Next
End Sub

ただ、あるフォルダの中にあるEXCEL ファイルの中から 大型、中型、小型のシートを
順番に見ていき、最初に ThisWorkbook の中のシート名と同じ製品名があったら、それを追記する(2つ目以降を見ない)というのが仕様かどうかが気になりました。

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
下記追記

また、全角変換したデータをシート名と比較していますが、シート名はすべて全角で書かれているのでしょうか。
下記で確認してはどうかと思います。

Sub wideCheck()
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name <> StrConv(ws.Name, vbWide) Then
            MsgBox "シート名に半角文字が含まれています。"
        End If
    Next
End Sub

アクティブブックの全部のシート名を全角変換するには下記でできます。
うえで引っかかるようでしたら、これを実施した後に最初のコードを実行してみてどうでしょうか。

Sub wideConv()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Name = StrConv(ws.Name, vbWide)
    Next
End Sub

コメントに提示されたコードは見づらいので下記に掲載しました(一部修正)。

Option Explicit

Private Sub CommandButton1_Click()
    Dim ShellApp As Object
    Dim oFolder As Object
    Dim wb As Workbook
    Dim fileName
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)
    MsgBox oFolder.Items.Item.Path, vbOKOnly, "フルパス表示!"
    
    Dim p
    p = oFolder.Items.Item.Path
    
    fileName = Dir(p & "\" & "*.xls", vbNormal)
    Do While fileName <> ""
        Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
        mySearch wb, Split(fileName, "・")(1) '// ***・県名・*** から県名を取得
        wb.Close
        fileName = Dir
    Loop

'// ★移動:ThisWorkbook へ対する処理ならこちらで実施すべき
    Application.ScreenUpdating = False
    Dim Sht As Worksheet
    For Each Sht In Worksheets
        Sht.Select
        'Call Nyuryoku
        Call AverageSheet
        'Call ClearCon
        Call SumSheet
        'Call ClearCon
    Next Sht
    Application.ScreenUpdating = True
End Sub
    
Sub mySearch(srcWB As Workbook, prefName)
    Dim productName As String
    Dim wsName
    Dim dstWS As Worksheet
    Dim dstRow As Long
    Dim r As Long
    For Each wsName In Array("大型", "パチンコ", "スロット")
        With srcWB.Worksheets(wsName)
            For r = 4 To Rows.Count
                productName = StrConv(.Cells(r, "D"), vbWide)
                If productName = "" Then Exit For
                On Error Resume Next
                Set dstWS = ThisWorkbook.Worksheets(productName)
                On Error GoTo 0
                
                If Not dstWS Is Nothing Then
                    dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    dstWS.Cells(dstRow, "B").Value = prefName
                    dstWS.Cells(dstRow, "C").Value = productName
                    dstWS.Cells(dstRow, "G").Value = .Range("J2")
                    dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
                    Set dstWS = Nothing '// 一応おまじない
                    ' すべてを検索する場合は①、②とも削除
                    Exit Sub    ' // ①見つけたら次のファイルを検索
                    ' Exit For  ' // ②見つけたら次のシートを検索
                End If
            Next
        End With
    Next
End Sub

各ファイルはシート名に半角文字が使われているようですが、全角・半角の運用は意図通りになっているでしょうか。

他7件のコメントを見る
id:japan-nan

最後に一つ質問があります。
各ファイルからシート名と同一の製品名を引っ張ってくることができました。
ただ、対象製品名の行下、全部の製品名も引っ張ってきました。

2011/11/14 22:41:04
id:Mook

そのあたりはどのようにしたいか仕様を説明してください。
検索対象のシートはどうなっていて、その中のどれ(どこまで)を持ってきたいのでしょうか?

コメントで書きましたが、各シートの先頭だけを持ってきたいのであれば、Exit Sub の代わりに Exit For にすればできます。
どちらでもない場合は、別途コードの変更が必要です。

2011/11/14 22:49:41

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/11/13 00:58:46

ポイント100pt

もとのソースをコメントに貼り付けてもらえれば 修正は 早いんですけどね。

一応、直し方だけ。

for a=4 to 65536
この行の前に フラグをクリアします。
フラグは 変数 flg とでもしましょう。

flg = 0
for a=4 to 65536

こんな感じです。

で exit for の前に フラグをたてます。
つまり、見つかったら フラグを 1にするのです。

flg = 1
exit for

で Next a の次に

if flg = 0 then
と入れて
for a=4 to 65536
から
Next a
の部分までを コピーして 入れます。
そして 大型のところを 中型にします。

Next aの次に
end if
と入れます。

この中型の箇所

if flg = 0 then
から
end if
までをコピーし、今度は 中型を 小型に変えます。

これで OKです。

id:japan-nan

上記の手順で書き換えたのですが、更新が行われませんでした。
どこの記述が間違えているのでしょうか?

Private Sub CommandButton1_Click()

Dim ShellApp As Object
Dim oFolder As Object
Set ShellApp = CreateObject("Shell.Application")
Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)

MsgBox oFolder.Items.Item.Path, vbOKOnly, "フルパス表示!"

p = oFolder.Items.Item.Path
f = Dir(p & "\\" & "*.xls", vbNormal)

Do While f <> ""
Set w = Workbooks.Open(fileName:=p & "\" & f, UpdateLinks:=False, ReadOnly:=True)

c1 = InStr(f, "・") + 1
c2 = InStr(c1, f, "・")
kenmei = Mid(f, c1, c2 - c1)

flg = 0
For a = 4 To 65536
seihin = w.Sheets("大型").Cells(a, 4)
If seihin = "" Then Exit For
seihin = StrConv(seihin, vbWide)

For Each myWS In ThisWorkbook.Worksheets
If myWS.Name = seihin Then
r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 2).End(xlUp).Row + 1
ThisWorkbook.Sheets(seihin).Cells(r, 2) = kenmei
ThisWorkbook.Sheets(seihin).Cells(r, 3) = seihin
ThisWorkbook.Sheets(seihin).Cells(r, 7) = w.Sheets("大型").Range("J2")
ThisWorkbook.Sheets(seihin).Cells(r, 8) = w.Sheets("大型").Cells(a, 8)
ThisWorkbook.Sheets(seihin).Cells(r, 9) = w.Sheets("大型").Cells(a, 9)
ThisWorkbook.Sheets(seihin).Cells(r, 10) = w.Sheets("大型").Cells(a, 10)

flg = 1
Exit For
End If
Next
Next a
If flg = 0 Then

For a = 4 To 65536
seihin = w.Sheets("中型").Cells(a, 4)
If seihin = "" Then Exit For
seihin = StrConv(seihin, vbWide)

For Each myWS In ThisWorkbook.Worksheets
If myWS.Name = seihin Then
r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 2).End(xlUp).Row + 1
ThisWorkbook.Sheets(seihin).Cells(r, 2) = kenmei
ThisWorkbook.Sheets(seihin).Cells(r, 3) = seihin
ThisWorkbook.Sheets(seihin).Cells(r, 7) = w.Sheets("中型").Range("J2")
ThisWorkbook.Sheets(seihin).Cells(r, 8) = w.Sheets("中型").Cells(a, 8)
ThisWorkbook.Sheets(seihin).Cells(r, 9) = w.Sheets("中型").Cells(a, 9)
ThisWorkbook.Sheets(seihin).Cells(r, 10) = w.Sheets("中型").Cells(a, 10)

flg = 1
Exit For
End If
Next
Next a
End If

If flg = 0 Then

For a = 4 To 65536
seihin = w.Sheets("小型").Cells(a, 4)
If seihin = "" Then Exit For
seihin = StrConv(seihin, vbWide)

For Each myWS In ThisWorkbook.Worksheets
If myWS.Name = seihin Then
r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 2).End(xlUp).Row + 1
ThisWorkbook.Sheets(seihin).Cells(r, 2) = kenmei
ThisWorkbook.Sheets(seihin).Cells(r, 3) = seihin
ThisWorkbook.Sheets(seihin).Cells(r, 7) = w.Sheets("小型").Range("J2")
ThisWorkbook.Sheets(seihin).Cells(r, 8) = w.Sheets("小型").Cells(a, 8)
ThisWorkbook.Sheets(seihin).Cells(r, 9) = w.Sheets("小型").Cells(a, 9)
ThisWorkbook.Sheets(seihin).Cells(r, 10) = w.Sheets("小型").Cells(a, 10)

flg = 1
Exit For
End If
Next
Next a
End If

If flg = 0 Then

w.Close saveChanges:=False
f = Dir

Loop

Application.ScreenUpdating = False
Dim Sht As Worksheet
For Each Sht In Worksheets
Sht.Select
Call AverageSheet
Call SumSheet
Next Sht
Application.ScreenUpdating = True

End Sub

2011/11/13 20:55:13
id:taknt

r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 2).End(xlUp).Row + 1

r = ThisWorkbook.Sheets(seihin).Rows.Count
r = ThisWorkbook.Sheets(seihin).Cells(r, 2).End(xlUp).Row + 1

にしてみたらいかがでしょうか?

2011/11/14 09:45:44
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/11/13 03:08:28ここでベストアンサー

ポイント1000pt

前段の部分が良く見えませんが、Dir 以降をこんな形にしてどうでしょうか。

Sub japan_nan()

     :
     :
     :

    Dim wb As Workbook
    Dim fileName
    fileName = Dir(p & "\" & "*.xls", vbNormal)
    Do While fileName <> ""
        Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
        mySearch wb, Split(fileName, "・")(1) '// ***・県名・*** から県名を取得
        wb.Close
        fileName = Dir
    Loop
End Sub

Sub mySearch(srcWB As Workbook, prefName)
    Dim productName As String
    Dim wsName
    Dim dstWS As Worksheet
    Dim dstRow As Range
    Dim r As Long
    For Each wsName In Array("大型", "中型", "小型")
        With srcWB.Worksheets(wsName)
            For r = 4 To Rows.Count
                productName = StrConv(.Cells(r, "D"), vbWide)
                If productName = "" Then Exit For
                
                On Error Resume Next
                Set dstWS = ThisWorkbook.Worksheets(productName)
                On Error GoTo 0
                
                If Not dstWS Is Nothing Then
                    dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    dstWS.Cells(dstRow, "B").Value = prefName
                    dstWS.Cells(dstRow, "C").Value = productName
                    dstWS.Cells(dstRow, "G").Value = .Range("J2")
                    dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
                    Exit Sub
                End If
            Next
        End With
    Next
End Sub

ただ、あるフォルダの中にあるEXCEL ファイルの中から 大型、中型、小型のシートを
順番に見ていき、最初に ThisWorkbook の中のシート名と同じ製品名があったら、それを追記する(2つ目以降を見ない)というのが仕様かどうかが気になりました。

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
下記追記

また、全角変換したデータをシート名と比較していますが、シート名はすべて全角で書かれているのでしょうか。
下記で確認してはどうかと思います。

Sub wideCheck()
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name <> StrConv(ws.Name, vbWide) Then
            MsgBox "シート名に半角文字が含まれています。"
        End If
    Next
End Sub

アクティブブックの全部のシート名を全角変換するには下記でできます。
うえで引っかかるようでしたら、これを実施した後に最初のコードを実行してみてどうでしょうか。

Sub wideConv()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Name = StrConv(ws.Name, vbWide)
    Next
End Sub

コメントに提示されたコードは見づらいので下記に掲載しました(一部修正)。

Option Explicit

Private Sub CommandButton1_Click()
    Dim ShellApp As Object
    Dim oFolder As Object
    Dim wb As Workbook
    Dim fileName
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)
    MsgBox oFolder.Items.Item.Path, vbOKOnly, "フルパス表示!"
    
    Dim p
    p = oFolder.Items.Item.Path
    
    fileName = Dir(p & "\" & "*.xls", vbNormal)
    Do While fileName <> ""
        Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
        mySearch wb, Split(fileName, "・")(1) '// ***・県名・*** から県名を取得
        wb.Close
        fileName = Dir
    Loop

'// ★移動:ThisWorkbook へ対する処理ならこちらで実施すべき
    Application.ScreenUpdating = False
    Dim Sht As Worksheet
    For Each Sht In Worksheets
        Sht.Select
        'Call Nyuryoku
        Call AverageSheet
        'Call ClearCon
        Call SumSheet
        'Call ClearCon
    Next Sht
    Application.ScreenUpdating = True
End Sub
    
Sub mySearch(srcWB As Workbook, prefName)
    Dim productName As String
    Dim wsName
    Dim dstWS As Worksheet
    Dim dstRow As Long
    Dim r As Long
    For Each wsName In Array("大型", "パチンコ", "スロット")
        With srcWB.Worksheets(wsName)
            For r = 4 To Rows.Count
                productName = StrConv(.Cells(r, "D"), vbWide)
                If productName = "" Then Exit For
                On Error Resume Next
                Set dstWS = ThisWorkbook.Worksheets(productName)
                On Error GoTo 0
                
                If Not dstWS Is Nothing Then
                    dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    dstWS.Cells(dstRow, "B").Value = prefName
                    dstWS.Cells(dstRow, "C").Value = productName
                    dstWS.Cells(dstRow, "G").Value = .Range("J2")
                    dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
                    Set dstWS = Nothing '// 一応おまじない
                    ' すべてを検索する場合は①、②とも削除
                    Exit Sub    ' // ①見つけたら次のファイルを検索
                    ' Exit For  ' // ②見つけたら次のシートを検索
                End If
            Next
        End With
    Next
End Sub

各ファイルはシート名に半角文字が使われているようですが、全角・半角の運用は意図通りになっているでしょうか。

他7件のコメントを見る
id:japan-nan

最後に一つ質問があります。
各ファイルからシート名と同一の製品名を引っ張ってくることができました。
ただ、対象製品名の行下、全部の製品名も引っ張ってきました。

2011/11/14 22:41:04
id:Mook

そのあたりはどのようにしたいか仕様を説明してください。
検索対象のシートはどうなっていて、その中のどれ(どこまで)を持ってきたいのでしょうか?

コメントで書きましたが、各シートの先頭だけを持ってきたいのであれば、Exit Sub の代わりに Exit For にすればできます。
どちらでもない場合は、別途コードの変更が必要です。

2011/11/14 22:49:41

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません