fork download
copy 
  1. Option Explicit
  2.  
  3.  
  4. Sub SearchAcrossBooks_OnePass()
  5.     Dim wsMain As Worksheet
  6.     Dim lastrow As Long, r As Long, endRow As Long
  7.     Dim dict As Object
  8.     Dim key As Variant, v As Variant
  9.     Dim Path As String, f As String
  10.     Dim wb As Workbook, ws As Worksheet
  11.     Dim rng As Range
  12.     Dim data As Variant
  13.     Dim i As Long, j As Long
  14.     Dim sc As Boolean, ev As Boolean, calc As XlCalculation
  15.     Dim cnt As Long
  16.     Dim FDL As FileDialog
  17.     Dim selFolder As String
  18.  
  19.     ' フォルダ選択ダイアログを作成
  20.     Set FDL = Application.FileDialog(msoFileDialogFolderPicker)
  21.  
  22.     ' ダイアログの初期フォルダ設定（オプション）
  23.     'FDL.InitialFileName = "C:\"
  24.  
  25.     ' ダイアログ表示し、フォルダが選択されたか確認
  26.     If FDL.Show = -1 Then
  27.         ' 選択されたフォルダパスを取得
  28.         selFolder = FDL.SelectedItems(1)
  29.     Else
  30.         'フォルダ選択がキャンセルの場合
  31.         Exit Sub
  32.     End If
  33.  
  34.     Set wsMain = ThisWorkbook.Sheets("判定")
  35.  
  36.     lastrow = wsMain.Cells(wsMain.Rows.Count, "E").End(xlUp).Row
  37.     If lastrow < 2 Then Exit Sub
  38.  
  39.     Set dict = CreateObject("Scripting.Dictionary")
  40.  
  41.     For r = 2 To lastrow
  42.         v = wsMain.Cells(r, "E").Value
  43.         If Len(v) = 0 Then Exit For
  44.         dict(CStr(v)) = 0
  45.     Next r
  46.     endRow = r - 1
  47.     If dict.Count = 0 Then Exit Sub
  48.  
  49.     sc = Application.ScreenUpdating
  50.     ev = Application.EnableEvents
  51.     calc = Application.Calculation
  52.     Application.ScreenUpdating = False
  53.     Application.EnableEvents = False
  54.     Application.Calculation = xlCalculationManual
  55.  
  56.  
  57.  
  58.     ' 同一フォルダ内の他ブックを集計
  59.     Path = selFolder & "\"
  60.     f = Dir(Path & "*.xls*")
  61.     Do While f <> ""
  62.         If Path & f <> ThisWorkbook.FullName Then
  63.             On Error Resume Next
  64.             Set wb = Workbooks.Open(Path & f, ReadOnly:=True)
  65.             If Err.Number = 0 Then
  66.                 On Error GoTo 0
  67.                 Call CountInWorkbook(wb, dict)
  68.                 wb.Close SaveChanges:=False
  69.             Else
  70.                 Err.clear
  71.                 On Error GoTo 0
  72.             End If
  73.         End If
  74.         f = Dir()
  75.     Loop
  76.  
  77.     ' 結果を書き戻し
  78.     For r = 2 To endRow
  79.         cnt = dict(CStr(wsMain.Cells(r, "E").Value))
  80.         Select Case cnt
  81.         'Case 0: wsMain.Cells(r, "A").Value = "×"
  82.         Case 1: wsMain.Cells(r, "A").Value = "◯"
  83.         'Case Else: wsMain.Cells(r, "A").Value = "△"
  84.         End Select
  85.     Next r
  86.  
  87.     Application.ScreenUpdating = sc
  88.     Application.EnableEvents = ev
  89.     Application.Calculation = calc
  90.  
  91. End Sub
  92.  
  93. Private Sub CountInWorkbook(wb As Workbook, dict As Object)
  94. Dim ws As Worksheet
  95. Dim rng As Range
  96. Dim data As Variant
  97. Dim i As Long, j As Long
  98. Dim v As Variant
  99.  
  100. For Each ws In wb.Worksheets
  101. Set rng = ws.UsedRange
  102. If Not rng Is Nothing Then
  103. If rng.Cells.CountLarge > 1 Then
  104. data = rng.Value
  105. If IsArray(data) Then
  106. For i = 1 To UBound(data, 1)
  107. For j = 1 To UBound(data, 2)
  108. v = data(i, j)
  109. If dict.Exists(CStr(v)) Then
  110. dict(CStr(v)) = dict(CStr(v)) + 1
  111. End If
  112. Next j
  113. Next i
  114. Else
  115. v = data
  116. If dict.Exists(CStr(v)) Then
  117. dict(CStr(v)) = dict(CStr(v)) + 1
  118. End If
  119. End If
  120. Else
  121. v = rng.Value
  122. If dict.Exists(CStr(v)) Then
  123. dict(CStr(v)) = dict(CStr(v)) + 1
  124. End If
  125. End If
  126. End If
  127. Next ws
  128.  
  129. End Sub
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/a85BaW
language:
Text (text 6.10)
created:
141 days ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!