スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

VBA関数メモ②

'クライアントデータ構造体
Type ClientData
'クライアント名
cName As String
'検索用ワード
sWord As String
'ファイルのパスワード
PassWord As String
End Type

'フォルダパス格納用変数
Dim folderPATH As String


'Main関数
'集計ツールメイン関数
Sub Main()
'正常に進行しているかのチェックフラグ
Dim checkProgress As Boolean
checkProgress = True

'クライアントデータ配列
Dim cDataArray() As ClientData

'Excelファイル名一覧格納用配列
Dim fNameArray() As String

'フォルダパスの読み込み
'読み込むセルを変えたかったらここを変更
folderPATH = Range("B7").Value

'Excelファイルの一覧を作成
fNameArray = MakeFileList(folderPATH, checkProgress)

'ファイル一覧が作成できなかったら
'関数を途中で終了させる
If checkProgress = False Then
Exit Sub
End If

'クライアントデータ配列の生成
cDataArray = MakeClientDataArray()

'出力先シートの作成
Call MakeOutputSheets(cDataArray)

'テスト用
Call TestOutput(cDataArray)

'集計

End Sub


'ファイル一覧作成用関数=====================================================================
'引数 :String FolderPATH, Boolean CheckProgress
'戻り値:Boolean
Function MakeFileList(folderPATH As String, ByRef checkProgress As Boolean) As String()
'Excelファイル名一覧格納用配列
Dim fNameArray() As String

'オブジェクトを生成
Set FS = CreateObject("Scripting.FileSystemObject")
' フォルダの存在確認
If FS.FolderExists(folderPATH) Then
'フォルダがあったので、取得
Set Fol = FS.GetFolder(folderPATH)
Else
'フォルダが見つからなくて生成失敗
MsgBox "指定のフォルダは存在しません。", vbExclamation
'失敗なのでFALSEを返す
checkProgress = False
Exit Function
End If

Set Fil = Fol.Files

'ファイル名一覧の初期化(とりあえず100件まで)
Range("F10:F110").ClearContents

'ループで回してファイル名をすべて書き出す
i = 10

'配列用インデックス
Dim aIndex As Integer
aIndex = 0

'自分自身のファイル名を取得
Dim activeBookName As String
activeBookName = ActiveWorkbook.Name

For Each Fx In Fil
'ファイル名
sFile = Fx.Name
'ファイルがExcelファイルか判定
If InStr(Fx.Type, "Microsoft Excel") Then
'Excelファイルだった場合
'ファイル名がこのファイルか判定
If sFile <> activeBookName Then
'このファイル名でなければファイル名を書き出す
ThisWorkbook.Sheets(1).Cells(i, 6) = sFile
'それと配列登録
ReDim Preserve fNameArray(aIndex)
fNameArray(aIndex) = sFile
'Indexの更新
aIndex = aIndex + 1
End If
End If
i = i + 1
Next

'生成ができたらTRUEを返す
checkProgress = True

MakeFileList = fNameArray

End Function
'========================================================================================


'Test用
Sub TestOutput(cDataArray() As ClientData)
Range("O2").Select
For i = 0 To 1
Range("O2").Offset(i, 0).Value = cDataArray(i).cName
Range("O2").Offset(i, 1).Value = cDataArray(i).sWord
Range("O2").Offset(i, 2).Value = cDataArray(i).PassWord
Next i
End Sub


'集計管理===============================================================================
'引数 :クライアントデータ一覧、ファイル名一覧
'戻り値:なし
Sub DataOutputManager(cDataArray() As ClientData, fNameArray() As String)
'クライアントの出力リスト
Dim outputList() As String

'出力リスト用インデックス
Dim olIndex As Integer
olIndex = 0

'Forで回して全部見る
For i = LBound(cDataArray) To UBound(cDataArray)
For j = LBound(fNameArray) To UBound(fNameArray)
'検索用ワードとファイル名を比較
If InStr(fNameArray(j), cDataArray(i).sWord) Then
'あったら出力リストに登録
ReDim Preserve outputList(olIndex)
outputList(olIndex) = fNameArray(j)
'Indexの更新
olIndex = olIndex + 1
End If
Next j
'クライアント名と出力リストを送る
If olIndex <> 0 Then
Call DataOutput(cDataArray(i).cName, outputList)
End If

'インデックスのリセット
olIndex = 0
Next i

End Sub

'結果出力
'引数 :クライアント名、出力リスト
'戻り値:
Sub DataOutput(cName As String, outputList() As String)
'
'クライアント名のシートに書き込み
'ファイルオープン
'UsedRangeプロパティでコピー範囲を選択
'SpecialCells(xlCellTypeLastCell)を使って最終列を取得
End Sub
'=========================================================================================
スポンサーサイト

VBA関数メモ①

'クライアントデータ一覧作成関数===========================================================
'引数 :なし
'戻り値:ClientData配列
Function MakeClientDataArray() As ClientData()
'クライアント名一覧格納用
'戻り値に使用
Dim cDataArray() As ClientData

'探索範囲の設定
'B10~値の入力がある最終行まで
Range("B10", Range("B" & Rows.Count).End(xlUp)).Select

'配列用インデックス
Dim i As Integer
i = 0

'選択されている範囲をループ処理
For Each c In Range("B10", Range("B" & Rows.Count).End(xlUp))
'配列の要素数を再定義
ReDim Preserve cDataArray(i)
'名前の取得
cDataArray(i).cName = c.Value

'検索用ワードの取得
cDataArray(i).sWord = c.Offset(0, 1).Value

'名前/検索用ワードがそろっているか調べる
If cDataArray(i).cName <> "" And cDataArray(i).sWord <> "" Then
'ファイルパスワードの取得
cDataArray(i).PassWord = c.Offset(0, 2).Value
'カウンタを進める
i = i + 1
End If
Next c

'クライアントデータ一覧の配列を返す
MakeClientDataArray = cDataArray

End Function
'============================================================================================


'出力先シート作成関数========================================================================
Sub MakeOutputSheets(cDataArray() As ClientData)

'For用変数
Dim i As Integer

'アクティブワークシート保持用変数
Dim aws As Worksheet
Set aws = ActiveSheet

'クライアント名の配列をForで回す
For i = LBound(cDataArray) To UBound(cDataArray)
'配列[i]にシート名が入っているか判断
'空白ならば何もしない
If cDataArray(i).cName <> "" Then
'空白でない場合
'配列[i]のクライアント名のシートが存在するか確認
If CheckSheetName(cDataArray(i).cName) Then
'存在する場合、該当シートを削除する
'シート選択
Sheets(cDataArray(i).cName).Select
Application.DisplayAlerts = False
'シート削除
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If

'シートを作成
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = cDataArray(i).cName
End If
Next i

'アクティブワークシートを戻す
aws.Activate

End Sub


'シート名がブック上に存在するか、チェックする関数
'引数 :String
'戻り値:Boolean
Function CheckSheetName(checkName As String) As Boolean
'Forで回して全シートの名前をチェックする
For i = 1 To ThisWorkbook.Sheets.Count
'引数の名前のシートがブック上に存在するかチェック
If ThisWorkbook.Sheets.Item(i).Name = checkName Then
'あればTRUEを返す
CheckSheetName = True
Exit Function
End If

Next

'全部確認して、なければFALSEを返す
CheckSheetName = False

End Function
'========================================================================================

当ブログについて

当ブログは個人的なメモとしての側面が
大変強いものとなります。

上記につきましてご留意ください。
プロフィール

Chainer

Author:Chainer
FC2ブログへようこそ!

最新記事
最新コメント
最新トラックバック
月別アーカイブ
カテゴリ
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。