HOMEへ
汎用コード======================================================
Option Explicit
'**
' CreateObject 利用頻度が高いもの
'------------------------------------------------------------------
' Access.Application ' Accessアプリケーション
' DAO.Database ' DAOデータベースオブジェクト
' ADODB.Connection ' ADOコネクションオブジェクト
' ACODB.Recordset ' ADOレコードセット
' Excel.Application ' Excelアプリケーション
' Excel.WorkBook ' Excelアプリケーション
' Excel.Worksheet ' Excelアプリケーション
' Scripting.FileSystemObject ' ファイルシステムオブジェクト
' Scripting.Dictionary ' ディクショナリオブジェクト
' WScript_Shell ' シェルオブジェクト
' Shell.Application ' シェルオブジェクト
' VBScript.RegExp ' 正規表現で使用するオブジェクト
'**
' 行 列 挿入 削除
'------------------------------------------------------------------
Public Sub RowColumnCmd()
With Sheet1
' 取得
' Debug.Print .Cells(.Rows.Count, 1).Row '最大行
' Debug.Print .Cells(.Rows.Count, 1).End(xlUp).Row '入力最終行
' Debug.Print .Cells(1, .Columns.Count).Column '最大列
' Debug.Print .Cells(1, .Columns.Count).End(xlToLeft).Column '入力最終列
' 挿入
' Debug.Print .Rows(3).Insert '単行挿入
' Debug.Print .Rows("1:3").Insert '複数行挿入
' Debug.Print .Range("1:3").Insert '(Range) 複数行挿入
' Debug.Print .Range("A1:B2").Insert '(Range) ※指定した範囲のみの行を挿入
' Debug.Print .Range("A1:B2").EntireRow.Insert '(Range) ※指定した範囲を含む行全体を挿入
' Debug.Print .Columns(3).Insert '単列挿入
' Debug.Print .Columns("A").Insert '単列挿入
' Debug.Print .Columns("A:B").Insert '複数行挿入 ※単数挿入の場合、引数は数字もOK
' Debug.Print .Range("A:C").EntireColumn.Insert '(Range) ※指定した範囲の行数を挿入
' Debug.Print .Range("A1:C3").EntireColumn.Insert '(Range) ※指定した範囲の行数を挿入
' Debug.Print .Range("A1:B2").Insert '(Range) ※指定した範囲のみの行を挿入
' 削除
' Debug.Print .Rows(1).Delete '単行削除
' Debug.Print .Rows("1:3").Delete '複数行削除
' Debug.Print .Range("A1").Delete '(Range) 単行削除
' Debug.Print .Range("A1:C3").Delete '(Range) ※指定した範囲のみの行を削除
' Debug.Print .Range("A1:C3").EntireRow.Delete '(Range) ※指定した範囲を含む行全体を削除
' Debug.Print .Columns(3).Delete '単列削除
' Debug.Print .Columns("A").Delete '単列削除
' Debug.Print .Columns("A:B").Delete '複数行削除 ※単数削除の場合、引数は数字もOK
' Debug.Print .Range("A:C").Delete '(Range) 複数行削除
' Debug.Print .Range(.Columns(1), .Columns(2)).Delete '(Range) 複数列削除
' Debug.Print .Range(.Columns("A"), .Columns("C")).Delete '(Range) 複数列削除
End With
End Sub
'**
' セル 最終行 最終列 範囲
'------------------------------------------------------------------
Public Sub AreaCmd()
Dim C As Long, r As Long
With Sheet1
r = .Cells(.Rows.Count, 2).End(xlUp).row '入力最終行
' .Range(.Cells(1, 1), .Cells(r, 2)).Select
C = .Cells(1, .Columns.Count).End(xlToLeft).Column '入力最終列
' .Range(.Cells(1, 1), .Cells(2, c)).Select
End With
End Sub
'**
' セル エリア 範囲 選択
'------------------------------------------------------------------
Public Sub AreaSelectCmd()
With Sheet15.Range("A1").CurrentRegion
'起点セルから10行分を指定(見出しを含む) → 選択
.Resize(10).Select
'起点セルから10行分を指定(見出しを含む) → offset(1)で1行分ずらして選択(見出しが含まなくなる)
.Resize(10).Offset(1).Select
'起点セルから最終行分を指定(見出しを含む) → 選択
.Resize(.Rows.Count).Select
'起点セルから(最終行 - 1)分を指定(見出しを含む) → offset(1)で1行分ずらして選択(見出しが含まなくなる)
.Resize(.Rows.Count - 1).Offset(1).Select
End With
End Sub
'**
' 文字列 関数
'------------------------------------------------------------------
Public Sub StringCmd()
Dim arr As Variant
With Sheet1
' String
' Debug.Print LCase(.Cells(1, 1).Value) '文字列内の大文字英字のみを小文字に変換
' Debug.Print UCase(.Cells(2, 1).Value) '文字列内の大文字英字のみを大文字に変換
' Debug.Print Mid(.Cells(1, 1).Value, 1, 4) '文字列内のn番目から指定数の文字を取得
' Debug.Print Left(.Cells(1, 1).Value, 3) '文字列左側から指定数の文字を取得
' Debug.Print Right(.Cells(1, 1).Value, 3) '文字列右側から指定数の文字を取得
' Debug.Print Len(.Cells(1, 1).Value) '文字列長
' Debug.Print LTrim(.Cells(1, 1).Value) '文字列左側にある空欄(半・全共に)を削除
' Debug.Print RTrim(.Cells(1, 1).Value) '文字列右側にある空欄(半・全共に)を削除
' arr = Split(.Cells(1, 1).Value, "-") '文字列内にある文字(指定可)にて文字列を分割
' Debug.Print arr(0), arr(1)
' Debug.Print Join(arr, "-") '配列列にある文字を特定文字(指定可)にて結合
' Debug.Print InStr(.Cells(1, 1).Value, "1-") '文字列内にある特定文字(指定可)の位置番号
' Debug.Print Replace(.Cells(1, 1).Value, "01-", "xx") '文字列内にある文字を指定した文字に変換 ※1文字以上でもOK
End With
End Sub
'**
' 日付
'------------------------------------------------------------------
Public Sub DateCmd()
With Sheet1
' String
' Debug.Print Now '現在日時
' Debug.Print Date '現在日付
' Debug.Print Time '現在時刻
' Debug.Print Timer '0時からの経過秒
' Debug.Print DateSerial(2025, 4, 3) '整数値から日付(2025/04/03型式)変換
' Debug.Print DateValue("2025/03/3") '文字列日付から日付(2025/03/03型式)変換
' (引数："2025/03/3"、"2025, 3, 3"、"2025年3月3日"→OK、"2025.3.3"は×)
' Debug.Print TimeSerial(17, 4, 3) '整数値から時刻(17:04:03型式)変換
' Debug.Print TimeValue("17時4分3秒") '文字列時刻から時刻(17:04:03型式)変換
' (引数："17:4:3"、"17.4.3"、"17時4分3秒"→OK、"17,4,3"は×)
' Dim d As Date: d = #4/1/2025 4:03:45 PM#
' Debug.Print Year(d), Month(d), Day(d)
' (引数：Now、Date→OK、Timeは×)
' Debug.Print Weekday(Date) '1～7
' (引数：Now、Date→OK、Timeは×)
' (戻り値：1:日、2:月、3:火、4:水、5:木、6:金、7:土)
' Debug.Print Hour(d), Minute(d), Second(d) '16 3 45
' (引数：Now、Time→OK、Dateは×)
' Debug.Print DateDiff("d", d, #4/30/2027#)
' (引数：yyyy、d、mなど→OK、yyは×)
' Debug.Print DateAdd("d", 10, d)
' (引数：yyyy、d、mなど→OK、yyは×)
End With
End Sub
'**
' フォーマット 書式
'------------------------------------------------------------------
Public Sub FormatCmd()
With Sheet1
Dim dbl As Double: dbl = -123456.789
' Debug.Print Format(dbl, "standard") '-123,456.79
' (※少なくとも整数部1桁、小数部2桁を表示。点以下は2桁表示で四捨五入)
' Debug.Print Format(dbl, "currency") '-\123,457
' (※小数点以下は四捨五入)
' Debug.Print Format(dbl, "percent") '-12345678.90%
' (※100倍して％表示、小数点以下は2桁表示)
' Debug.Print Format(dbl, "0.0000") '-123456.7890
' (※数値が書式の桁数より小さい場合、0で埋められる)
' Debug.Print Format(dbl, "#,##0") '-123456.7890
' (※数値が書式の桁数より小さい場合、0で埋められる)
End With
End Sub
'**
' メッセージ
'------------------------------------------------------------------
Public Sub MsgCmd()
Dim str As String: str = "ボタンを押してください"
' Debug.Print MsgBox(str, vbOKOnly + vbInformation, "確認")
' (※戻り値 vbOK:1)
' Debug.Print MsgBox(str, vbOKCancel + vbInformation, "確認")
' (※戻り値 vbOK:1、vbCancel:2)
' Debug.Print MsgBox(str, vbAbortRetryIgnore + vbInformation, "確認")
' (※戻り値 vbAbort(中止):3、vbRetry(再試行):4、vbIgnore(無視):5)
' Debug.Print MsgBox(str, vbYesNoCancel + vbInformation, "確認")
' (※戻り値 vbYes:6、vbNo:7、vbCancel:2)
' Debug.Print MsgBox(str, vbYesNoCancel + vbInformation, "確認")
' (※戻り値 vbYes:6、vbNo:7、vbCancel:2)
' str = "入力してください"
' Debug.Print InputBox(str, "再確認")
' (※戻り値 OK:入力値、キャンセル:無し)
End Sub
'**
' セル 背景色 フォント 太字
'------------------------------------------------------------------
Public Sub CellEditCmd1()
With Sheet1
' .Cells(1, 1).Interior.Color = RGB(255, 220, 50) 'セル背景色
' .Cells(1, 1).Font.Color = RGB(255, 0, 255) 'セルフォント色
' .Cells(1, 1).Font.Bold = True 'セルフォント太字
End With
End Sub
'**
' セル 背景色 フォント 太字
'------------------------------------------------------------------
Public Sub CellEditCmd2()
With Sheet1
'反対セル（右隣）の見た目を処理
.Cells(1, 5 - 1).Font.ColorIndex = 15
.Cells(2, 5 - 1).Interior.ColorIndex = xlNone
With .Cells(2, 5 - 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
'選択セルの見た目を処理
.Cells(3, 5).Font.ColorIndex = 1
.Cells(5, 5).Interior.ColorIndex = 45
With .Cells(3, 5).Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
End With
End Sub
'**
' コピー
'------------------------------------------------------------------
Public Sub CopyCmd()
' Dim startTM As Date: startTM = Time
'
Dim sh3 As Worksheet: Set sh3 = Worksheets("Sheet3")
Call AllDataDeleteCmd(sh3)
'
With Worksheets("dat")
Dim r As Long
r = .Cells(.Rows.Count, 12).End(xlUp).row '入力最終行
'
' Copyメソッドは使用せずにValueにデータを格納するイメージ
' sh3.Range(sh3.Cells(1, 1), sh3.Cells(r, 12)).Value = .Range(.Cells(1, 1), .Cells(r, 12)).Value '①
' (同じ大きさの範囲同士でコピーする場合には、必ずValueプロパティを記載 ※但し、書式等はコピーされない。100000万件のコピーで約3秒)
'
' Dim MyArray As Variant: MyArray = .Range(.Cells(1, 1), .Cells(r, 12)) '②
' sh3.Range(sh3.Cells(1, 1), sh3.Cells(r, 12)) = MyArray '②
' (予め配列に格納した上でコピー。Valueの有無は処理速度に影響しないと思われる。書式等はコピーされない。100000万件のコピーで約3秒)
'
' Copyメソッドを使用
' .Range(.Cells(1, 1), .Cells(r, 6)).Copy sh3.Cells(1, 1)
' (書式等もコピーされる。データ量が多くても上記方法より処理が早い(100000万件のコピーで約1秒))
'
.Range(.Cells(1, 1), .Cells(r, 12)).Copy sh3.Cells(1, 1) '③
' .Range(.Cells(1, 1), .Cells(r, 12)).Copy Destination:=sh3.Cells(1, 1) '④
' .Range(.Cells(1, 1), .Cells(r, 12)).Copy '⑤
' sh3.Cells(1, 1).PasteSpecial xlPasteAll '⑤
' (③、④、⑤の方法は、100000万件のコピーで約1秒))
'
End With
'
' Dim endTM As Date: endTM = Time
' Debug.Print Minute((endTM - startTM) * 60 + Second(endTM - startTM))
End Sub
'**
' 全セル内容削除
'------------------------------------------------------------------
Public Sub AllDataDeleteCmd(ws As Worksheet)
ws.Cells.Clear
End Sub
'**
' テーブル 作成 変換
'------------------------------------------------------------------
Public Sub CreateTableCmd(ws As Worksheet)
' With ws
' Dim c As Long, r As Long
' c = .Cells(1, .Columns.Count).End(xlToLeft).Column '入力最終行
' r = .Cells(.Rows.Count, c).End(xlUp).Row '入力最終行
'
' With .ListObjects.Add(xlSrcRange, .Range(.Cells(1, 1), .Cells(r, c)))
' .Name = "DATALIST"
' .TableStyle = ""
' End With
'
' End With
End Sub
'**
' テーブル 行 列 範囲 値
'------------------------------------------------------------------
Public Sub TablePartsCmd()
' Dim tbl As ListObject: Set tbl = Sheets("table").ListObjects(1)
'
' With tbl
' Debug.Print .Name 'テーブル名
' Debug.Print .Parent.Name 'テーブルがあるシート名
' Debug.Print .ListRows.Count 'ヘッダーを除く行数
' Debug.Print .ListColumns.Count '列数
' Debug.Print .Range.Address 'テーブル範囲(ヘッダー、集計行等も含む)
' Debug.Print .HeaderRowRange.Address 'ヘッダー範囲
' Debug.Print .DataBodyRange.Address ' ヘッダー、集計行を除いたボディ範囲
' Debug.Print .TotalsRowRange.Address '集計行範囲
'
' With .ListRows(1)
' Dim v As Variant: v = .Range.Value
' Debug.Print .Range(1).Value
' Debug.Print .Range(2).Value
' Debug.Print .Range(3).Value
' End With
'
' Debug.Print .ListRows(2).Range(3).Value
'
' End With
End Sub
'**
' ソート
' フィールドと順序は3つまで指定可
'------------------------------------------------------------------
Public Sub SortCmd()
With Worksheets("Sheet4")
Dim r As Long
r = .Cells(.Rows.Count, 5).End(xlUp).row '入力最終行
.Range(.Cells(2, 2), .Cells(r, 5)).Sort _
key1:=.Range(.Cells(2, 4), .Cells(2, 4)), Order1:=xlAscending, _
key2:=.Range(.Cells(2, 2), .Cells(2, 2)), Order2:=xlDescending, _
Header:=xlYes
End With
End Sub
'**
' 検索 Find
' what(検索値)、LookIn(検索対象：値、数式など)
' LookAt(検索方法：部分、完全一致)
' MatchCase(大文字、小文字の区別)、MatchByte(全角、半角の区別)
'------------------------------------------------------------------
Public Sub FindCmd()
With Worksheets("table")
Dim C As Long, r As Long
C = .Cells(1, .Columns.Count).End(xlToLeft).Column '入力最終行
r = .Cells(.Rows.Count, C).End(xlUp).row '入力最終行
'見つかったら場合 最初のセルアドレス格納
With .Range(.Cells(1, 1), .Cells(r, C))
Dim rng As Range
Set rng = .Find(what:="BNI01-13-0390c", LookIn:=xlValues, LookAt:=xlPart)
'見つかったら場合 最初のセルアドレス格納
If Not rng Is Nothing Then
Dim FirstAddress As String: FirstAddress = rng.Address
Do
Debug.Print rng.Address
Set rng = .FindNext(rng)
Loop While rng.Address <> FirstAddress
End If
End With
End With
End Sub
'**
' 置き換え 置換え
' what(検索値)、Replace(置換え後の値)
' LookAt(検索方法：部分、完全一致)
' MatchCase(大文字、小文字の区別)、MatchByte(全角、半角の区別)
'------------------------------------------------------------------
Public Sub ReplaceCmd()
With Worksheets("Sheet4")
Dim C As Long, r As Long
C = .Cells(2, .Columns.Count).End(xlToLeft).Column '入力最終行
r = .Cells(.Rows.Count, C).End(xlUp).row '入力最終行
'見つかったら場合 最初のセルアドレス格納
With .Range(.Cells(1, 1), .Cells(r, C))
' .Replace _
' what:="female", replacement:="女性", _
' LookAt:=xlPart
'
' .Replace _
' what:="male", replacement:="男性", _
' LookAt:=xlPart
.Replace _
what:="女性", replacement:="female", _
LookAt:=xlPart
.Replace _
what:="男性", replacement:="male", _
LookAt:=xlPart
End With
End With
End Sub
'**
' オートフィルタ 設定
' what(検索値)、Replace(置換え後の値)
' LookAt(検索方法：部分、完全一致)
' MatchCase(大文字、小文字の区別)、MatchByte(全角、半角の区別)
'------------------------------------------------------------------
Public Sub AutoFilterCmd()
With Worksheets("table").Range("A1")
.AutoFilter Field:=5, _
Criteria1:="ケミカル異形ボルト", _
Operator:=xlAnd
End With
End Sub
'**
' エクスプローラー 検索
'
'------------------------------------------------------------------
Public Sub GoogleSearchSample()
' オブジェクト
'--------------------------------------
Dim objIE As Object
Dim objInput As Object
' インスタンス作成
'--------------------------------------
Set objIE = CreateObject("InternetExplorer.Application")
With objIE
' IEの表示
.Visible = True
' 表示URL
.Navigate "https://www.google.co.jp/"
' 読込みが終わるまで待機
Do While .busy Or .ReadyState <> 4
DoEvents
Loop
' 検索窓へのキーワード入力
.Document.getElementsByName("q")(0).Value = "VBA"
' DOMより「Google 検索」ボタンを探してクリック
For Each objInput In .Document.getElementsByTagName("INPUT")
If objInput.Value = "Google 検索" Then
objInput.Click
Exit For
End If
Next
End With
End Sub
'**
' 小数点以下・特定桁の切り上げ
' @param {Val : Double} 実数
' {Cnt : Integer} 切り上げ桁
' @return {RoundUpValue : Double} 切り上げ済み実数
'------------------------------------------------------------------
Function RoundUpValue(val As Double, cnt As Integer) As Double
Dim i As Integer
Dim dat As Double
'10 ^ Cnt = べき乗
dat = ((val * 10 ^ cnt) + 9) / 10
dat = Int(dat)
If cnt > 1 Then
For i = 1 To cnt - 1
dat = dat / 10
Next i
End If
RoundUpValue = dat
End Function
'**
' 小数点以下・特定桁の切り下げ
' @param {Val : Double} 実数
' {Cnt : Integer} 切り下げ桁
' @return {RoundDownValue : Double} 切り下げ済み実数
'------------------------------------------------------------------
Function RoundDownValue(val As Double, cnt As Integer) As Double
Dim i As Integer
Dim dat As Double
'10 ^ Cnt = べき乗
dat = (val * 10 ^ cnt) / 10
dat = Int(dat)
If cnt > 1 Then
For i = 1 To cnt - 1
dat = dat / 10
Next i
End If
RoundDownValue = dat
End Function
'**
' 数値マッチングチェック
' @param {Txt : String} チェック対象数字 or 文字
' {Ptn : String} 設定正規表現パターン
' @正規表現パターン
' "^[0-9]+$"：連続数値
' "^0\d-\d{4}-\d{4}$"：固定電話
' "^(070|080|090)-\d{4}-\d{4}$"：携帯電話
' "^\d{3}-\d{4}$"：郵便番号
' "^[A-Z]+$"：大文字26英字
' "^[a-z]+$"：小文字26英字
' "^[A-Za-z0-9]+$"：英数字
' "^[A-Za-z]+$"：大文字小文字26英字
' "\d{4}-\d{2}-\d{2}"：YYYY-MM-DD
' "20\d{2}(([^\d]"：YYYY.MM.DD
' @return {NumericCheck : Boolean}
'------------------------------------------------------------------
Function PatternCheck(Txt As String, Ptn As String) As Boolean
Dim Reg As Object: Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Pattern = Ptn
.IgnoreCase = False
.Global = True
End With
PatternCheck = True
If Reg.test(Txt) = False Then PatternCheck = False
End Function
'**
' 曜日取得
' @param {wk : String} 日付 "例:2025/[0]5/[0]2"
' @return {GetWeek : String} 曜日
'------------------------------------------------------------------
Function GetWeek(ByVal wk As String) As String
Dim weekName As Variant
weekName = Array("日", "月", "火", "水", "木", "金", "土")
GetWeek = weekName(Weekday(CDate(wk)) - 1)
End Function
'**
' 西暦 特定 取得
' 過去90年分の西暦を作成
' @return {YearArrayCreate : String()}
'------------------------------------------------------------------
Function YearArrayCreate() As String()
'表示年数の設定
Const max As Integer = 90
Dim arr(max) As String
Dim i As Long, j As Long
For i = CLng(Year(Date)) - max To CLng(Year(Date))
arr(j) = CStr(i) & "年"
j = j + 1
Next i
YearArrayCreate = arr()
End Function
Sub test()
' コピー元の列番号を格納
' 左から プロジェクトA プロジェクトB プロジェクトC プロジェクトD プロジェクトE
'------------------------------------------------------------------
Dim copyCol() As Variant
copyCol = Array(2, 4, 6, 8, 10)
' コピー左の列番号を格納
' 左から プロジェクトA プロジェクトB プロジェクトC プロジェクトD プロジェクトE
'------------------------------------------------------------------
Dim destCol() As Variant
destCol = Array(41, 2, 54, 28, 15)
Dim monthly As Variant
Dim dstAcol As Integer, dstBcol As Integer, dstCcol As Integer, dstDcol As Integer, dstEcol As Integer
Dim lastCell As Integer: lastCell = 11
Dim destSheet As Worksheet: Set destSheet = Worksheets("Sheet3")
Dim firstMonth As Integer: firstMonth = 4
Dim lastMonth As Integer: lastMonth = 15
Dim r As Long
r = destSheet.Cells(destSheet.Cells.Rows.Count, 1).End(xlUp).Row + 1
With Sheets("sampletbl")
Dim i As Integer
For i = LBound(copyCol) To UBound(copyCol)
monthly = .Range(.Cells(firstMonth, copyCol(i)), .Cells(lastMonth, copyCol(i))).Value
destSheet.Range(destSheet.Cells(r, destCol(i)), destSheet.Cells(r, destCol(i) + lastCell)).Value = WorksheetFunction.Transpose(monthly)
Next i
End With
End Sub
' **
' レポート作成
'
Private Sub reportSheetCreate()
Worksheets("集計表").Copy after:=Worksheets(Worksheets.Count)
Dim SAVE_DIR As String
Dim newBook As Workbook
Dim newSheet As Worksheet: Set newSheet = ActiveSheet
Move
Set newBook = ActiveWorkbook
SAVE_DIR = ThisWorkbook.Path
Application.DisplayAlerts = False
newBook.SaveAs FileName:=SAVE_DIR & "\NewWorkbook.xlsm"
Application.DisplayAlerts = True
' With newSheet
'プロジェクトコード
Dim projectCD As String
' Dim datArray As Variant
' datArray = Range("C2:AG6").Value
' Range("C2:AG6").Value = datArray
' Dim startRow As Long: startRow = 2
' Dim lastRow As Long
' Dim lastCol As Long
'
' lastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
' lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
' .Range("C" & startRow & ":AG" & lastRow).Value = .Range("C" & startRow & ":AG" & lastRow).Value
' .Name = "new集計表"
' End With
mainSheet.Activate
mainSheet.Copy after:=Worksheets("リストシート")
Worksheets("リストシート (2)").Move
Set depotbook = ActiveWorkbook
With depotbook
.Worksheets("リストシート (2)").Name = "リストシート(変更名)"
End With
bkupfdr = ThisWorkbook.Path & "\出力リスト\デポ別リスト\" & Format(Date + 1, "YYYYMMDD") & "\"
If Dir(bkupfdr, vbDirectory) = vbNullString Then
MkDir bkupfdr
.SaveAs FileName:=bkupfdr & "【" & depotname & "】" & Format(Date + 1, "YYYYMMDD") & "リサイクル発生リスト" & ".xls", FileFormat:=xlExcel8
.Close
Else
bkupfdr = ThisWorkbook.Path & "\出力リスト\デポ別リスト\" & Format(Date + 1, "YYYYMMDD") & "\"
.SaveAs FileName:=bkupfdr & "【" & depotname & "】" & Format(Date + 1, "YYYYMMDD") & "リサイクル発生リスト" & ".xls", FileFormat:=xlExcel8
.Close
End If
targetsheet.Activate
.Rows(2 & ":" & lastRow).Delete Shift:=xlUp
ActiveWorkbook.Close
ThisWorkbook.Close
End Sub
Public Sub newSheetSave(ByRef newBook As Workbook)
Dim newSheet As Worksheet
Set newSheet = newBook.Worksheets(1)
Dim projectName As String, savePath As String
'保存パス
savePath = ThisWorkbook.Path & "\"
Application.DisplayAlerts = False
With newSheet
'プロジェクト名
projectName = .Range("A2")
.Range("A1").Activate
End With
'保存
newBook.SaveAs savePath & projectName & "_" & Format(Date, "mmddyyyy") & ".xlsx"
newBook.Close
Application.DisplayAlerts = True
End Sub
Public Sub tableEdit(ByRef newBook As Workbook)
Dim newSheet As Worksheet
Set newSheet = newBook.Worksheets(1)
'過去5年分の西暦を格納
'------------------------------------------------------------------
Dim dat_ary(1 To 5) As Integer
dat_ary(1) = 2019
dat_ary(2) = 2020
dat_ary(3) = 2021
dat_ary(4) = 2022
dat_ary(5) = 2023
'各西暦に対応した表の編集
'------------------------------------------------------------------
Dim kwd As Variant
For Each kwd In dat_ary()
Dim yearTitleRow As Long
Dim tblHeaderRow As Long
Dim tblBodyRow As Long
Dim tblLastRow As Long
Dim tblLastCol As Long
Dim funcStartCol As Long
With newSheet
'年タイトル行
yearTitleRow = .Columns(1).Find(kwd).Row
'表見出し行
tblHeaderRow = yearTitleRow + 1
'表入力行
tblBodyRow = tblHeaderRow + 1
'表最終行
tblLastRow = yearTitleRow + .Range("A" & tblHeaderRow).CurrentRegion.Rows.Count - 1
'表最終列
tblLastCol = .Range("A" & tblHeaderRow).CurrentRegion.Columns.Count
'COUNT関数の設定開始列
funcStartCol = .Rows(tblHeaderRow).Find("ItemCD").Column + 1
'入力エリア 最上段の「名前」に入力があるかどうか
If .Range("C" & tblBodyRow).Value <> "" Then
'合計関数以外の表データを値変換
.Range(.Cells(tblHeaderRow + 1, 1), .Cells(tblLastRow - 1, tblLastCol - 1)).Value = _
.Range(.Cells(tblHeaderRow + 1, 1), .Cells(tblLastRow - 1, tblLastCol - 1)).Value
'★チェック用 変換範囲の色付け
'.Range(.Cells(tblHeaderRow + 1, 1), .Cells(tblLastRow - 1, tblLastCol - 1)).Interior.Color = RGB(255, 220, 50)
'.Range(.Cells(tblHeaderRow + 1, 1), .Cells(tblLastRow - 1, tblLastCol - 1)).Select
'COUNT関数の設定
Dim i As Integer
For i = funcStartCol To tblLastCol - 1
.Cells(yearTitleRow, i) = _
WorksheetFunction.Count(Range(.Cells(tblBodyRow, i), .Cells(tblLastRow - 1, i)))
Next i
End If
End With
Next kwd
End Sub
Public Sub reportCreateTest()
Application.ScreenUpdating = False
'シートをコピー
'------------------------------------------------------------------
Dim newBook As Workbook
Worksheets("sampletbl").Copy
Set newBook = ActiveWorkbook
'表の編集
'------------------------------------------------------------------
Call tableEdit(newBook)
'保存
'------------------------------------------------------------------
Call newSheetSave(newBook)
MsgBox "レポートが作成されました"
Application.ScreenUpdating = True
End Sub
Private Sub UseClassModule()
Dim TableRange As Range
Dim TableValue As Variant
With ThisWorkbook.Worksheets("Sheet1").Range("A3").CurrentRegion
.Resize(.Rows.Count - 1).Select
.Resize(.Rows.Count - 1).Offset(1).Select
Set TableRange = .Resize(.Rows.Count - 1).Offset(1)
End With
TableValue = TableRange.Value
Dim oStudents As Students
Set oStudents = New Students
Dim i As Long
For i = LBound(TableValue) To UBound(TableValue)
oStudents.Add TableValue(i, 1), TableValue(i, 2), TableValue(i, 3), TableValue(i, 4)
Next i
Dim vIndex As Variant
vIndex = oStudents.SearchItemIndex("A0003")
If vIndex = False Then
MsgBox "指定したIDは見つかりません", vbInformation
Else
Debug.Print oStudents.Item(vIndex).Age
TableValue(vIndex, 3) = 17
End If
TableRange.Value = TableValue
Set oStudents = Nothing
End Sub
Public Sub test100()
Dim fileName As String: fileName = "bbb_"
Dim changeName As String: changeName = "ccc.txt"
Dim fileCount As Long, fileBool As Boolean
fileCount = isFileCount(ThisWorkbook.Path, fileName)
If fileCount = 1 Then
fileBool = isFileExists(ThisWorkbook.Path, changeName)
If Not fileBool Then
Call fileNameChange(ThisWorkbook.Path, fileName, changeName)
Else
Call fileNameChange(ThisWorkbook.Path, fileName, changeName)
End If
MsgBox fileBool
Else
'ファイルが1つも無いか、複数ある場合
MsgBox "Just prepare one file", vbInformation
End If
End Sub
Option Explicit
Public Function createFileObject() As Object
Set createFileObject = createObject("Scripting.FileSystemObject")
End Function
Public Function isFileCount(ByVal checkPath As String, ByVal fName As String) As Long
Dim fso As Object
Dim objFolder As Object, obj As Object
Set fso = createFileObject
Set objFolder = fso.GetFolder(checkPath)
Dim cnt As Long: cnt = 0
For Each obj In objFolder.Files
If obj.Name Like fName & "*.txt" Then
cnt = cnt + 1
End If
Next obj
isFileCount = cnt
End Function
Public Function isFileExists(ByVal checkPath As String, ByVal fName As String) As Boolean
Dim fso As Object
Dim objFolder As Object, obj As Object
Set fso = createFileObject
Set objFolder = fso.GetFolder(checkPath)
isFileExists = False
If fso.FileExists(checkPath & "\" & fName) Then
isFileExists = True
End If
End Function
Public Sub fileNameChange(ByVal checkPath As String, ByVal fName As String, ByVal changeName As String)
Dim fso As Object
Dim objFolder As Object, obj As Object
Set fso = createFileObject
Set objFolder = fso.GetFolder(checkPath)
For Each obj In objFolder.Files
If obj.Name Like fName & "*.txt" Then
obj.Name = changeName
End If
Next obj
End Sub
Public Sub test200()
Dim thisBook As Workbook
Dim ws As Worksheet
Dim fPath As String
Application.DisplayAlerts = False
Set thisBook = ThisWorkbook
fPath = thisBook.Path
For Each ws In thisBook.Worksheets
'アイテム毎のフォルダ有無チェック
If Dir(fPath & "\" & ws.Name, vbDirectory) <> "" Then
Dim tempBook As Workbook: Set tempBook = Workbooks.Open(fPath & "\temp\temp.xlsx")
Dim folName As String: folName = fPath & "\" & ws.Name & "\"
With ws
Dim maxRw As Long
Dim targetRw As Long
Dim cd As String
Dim tx As String
'マクロファイルのクエリ更新
'テンプファイル有無チェック
'テンプファイルオープン
'テンプファイルのクエリ更新
'
'マクロファイルリスト取得＆ループ
'リストのコードをテンプファイルにセット
'リストのコードにてテンプファイルをソート
'続けてコードにて過去ファイルを検索
'過去ファイルが有ったらオープン
'過去ファイルより特定範囲をコピー
'テンプファイルに貼り付け
'テンプファイルの特定箇所の色付け
'テンプファイルを別名で保存
'
maxRw = .Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To 10
targetRw = Int((maxRw - 1 + 1) * Rnd + 1)
If targetRw = 1 Then
targetRw = targetRw + 1
End If
cd = .Cells(targetRw, 3).Value
tx = .Cells(targetRw, 6).Value
With tempBook
With .Worksheets("sheet1")
.Range("A2").Value = cd
.Range("B2").Value = tx
End With
With .Worksheets("main")
If .AutoFilter.FilterMode = True Then
.ShowAllData
End If
With .Range("A1")
.AutoFilter Field:=2, _
Criteria1:=cd
End With
End With
Dim fName As String
fName = cd & ".xlsx"
.SaveCopyAs folName & fName
End With
Next i
End With
End If
Next ws
tempBook.Close
Application.DisplayAlerts = True
End Sub
Public Sub test100()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
With ws.ListObjects(1)
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
.AutoFilter 2, "A0006"
End With
Dim ftrRng As Range
Set ftrRng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
Dim cnt As Long
Dim rng As Range
For Each rng In ftrRng.Areas
cnt = cnt + rng.EntireRow.Count
Next
Debug.Print cnt - 1
End With
End Sub
Public Sub test101()
Dim shCol As New Collection
Dim c As Variant
Dim ws As Worksheet
Dim shArray(1 To 2, 1 To 2) As Variant
Dim i As Long, j As Long
shArray(1, 1) = "Sheet2"
shArray(1, 2) = "MTB"
shArray(2, 1) = "Sheet1"
shArray(2, 2) = "tbl"
For i = LBound(shArray, 1) To UBound(shArray, 1)
For Each ws In Worksheets
If shArray(i, 1) = ws.name Then
With ws.ListObjects(shArray(i, 2))
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
.AutoFilter 2, "A0001"
End With
j = .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count - 1
Debug.Print j
.ShowTotals = True
End With
End If
Next ws
Next i
End Sub
Public Sub test300()
Dim kongetsu As Workbook
Dim sengetsu As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set kongetsu = ThisWorkbook
Set sengetsu = Workbooks("sengetsu.xlsm")
Set ws1 = kongetsu.Worksheets("boltset")
Set ws2 = sengetsu.Worksheets("boltset")
With ws2.ListObjects(1)
Dim j As Long
For j = 1 To .ListColumns("ItemCD").DataBodyRange.Count
Debug.Print .ListColumns("ItemCD").DataBodyRange(j)
Next
End With
With ws1.ListObjects(1)
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
.AutoFilter 4, "1551"
Dim i As Long
i = ws1.ListObjects(1).AutoFilter.Range.Columns(4).SpecialCells(xlVisible).Count - 1
If i > 0 Then
Dim rng As Range
With .Range("C6").CurrentRegion
For Each rng In .SpecialCells(xlVisible).Rows
Debug.Print rng.Columns(3).Value
Next
End With
End If
End With
.ShowTotals = True
End With
End Sub
Public Sub test300()
Dim ws1 As Worksheet
Dim tblobj As ListObject
Dim ftrng As Range, tgtrng As Range
Set ws1 = ThisWorkbook.Worksheets("test")
Set tblobj = ws1.ListObjects(1)
Set ftrng = tblobj.Range
With tblobj
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
.ShowTotals = True
End With
With ftrng
.AutoFilter 4, "1550"
Dim i As Long, j As Long
i = .Columns(4).SpecialCells(xlVisible).Count - 1
Debug.Print i
End With
Dim c As Object
Set tgtrng = tblobj.DataBodyRange.Columns(4).SpecialCells(xlVisible)
j = 0
For Each c In tgtrng
Debug.Print c
j = j + 1
Next c
Debug.Print j
End Sub
Public Sub test400()
Dim ws As Worksheet
Dim tblObj As ListObject
Dim filterRng As Range, targetRng As Range
Set ws = ThisWorkbook.Worksheets("test")
Set tblObj = ws.ListObjects(1)
Set filterRng = tblObj.Range
With tblObj
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
Dim num As Long
num = 1550
With .Range
.AutoFilter 4, ">=" & num
End With
Dim i As Long, j As Long: j = 0
Dim c As Object
Set targetRng = .DataBodyRange.Columns(4).SpecialCells(xlCellTypeVisible)
i = targetRng.Count
For Each c In targetRng
ws.Cells(c.Row, 17).Value = c.Columns(-2).Value
ws.Cells(c.Row, 18).Value = c.Columns(0).Value
j = j + 1
Next c
.ShowTotals = True
End With
End Sub
Public Function filterCountCheck(ByRef tbl As ListObject, ByVal filterCol As Long, ByVal kwd As Long) As Long
filterCountCheck = 0
With tbl
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
Dim cnt As Long
.AutoFilter filterCol, kwd
filterCountCheck = .Columns(filterCol).SpecialCells(xlCellTypeVisible).Count - 1
End With
.ShowTotals = True
End With
End Function
Public Sub test()
Dim macroBook As Workbook: Set macroBook = ThisWorkbook
Dim macroSheet As Worksheet: Set macroSheet = macroBook.Worksheets("list")
Dim fPath As String: fPath = macroBook.Path
With macroSheet
Dim cnt As Long
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim thisBook As Workbook: Set thisBook = Workbooks.Open(fPath & "\" & "code.xlsm", UpdateLinks:=0)
Dim thisSheet As Worksheet: Set thisSheet = thisBook.Worksheets("itemcode")
For cnt = 2 To lastRow
Dim lastBookPath As String
Dim code As String
Dim i As Long, j As Long
code = .Cells(i, 2).Value
lastBookPath = fPath & "\archive\" & code & ".xlsx"
If Dir(lastBookPath) <> "" Then
Dim lastBook As Workbook: Set lastBook = Workbooks.Open(lastBookPath, UpdateLinks:=0)
Dim lastSheet As Worksheet: Set lastSheet = lastBook.Worksheets("main")
i = filterCountCheck1(lastSheet, 2, code)
Stop
End If
' With thisSheet.ListObjects(1)
'
' If .ShowTotals = True Then
' .ShowTotals = False
' End If
'
' If .AutoFilter.FilterMode = True Then
' .AutoFilter.ShowAllData
' End If
'
' With .Range
' Dim cnt As Long
' .AutoFilter filterCol, kwd
' filterCountCheck = .Columns(filterCol).SpecialCells(xlCellTypeVisible).Count - 1
' End With
'
' .ShowTotals = True
'
' End With
Next cnt
thisBook.Close
End With
End Sub
Public Function filterCountCheck1(ByRef ws As Worksheet, ByVal filterCol As Long, ByVal kwd As Long) As Long
filterCountCheck = 0
With ws.Range
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
Dim cnt As Long
.AutoFilter filterCol, kwd
filterCountCheck = .Columns(filterCol).SpecialCells(xlCellTypeVisible).Count - 1
End With
.ShowTotals = True
End With
End Function
Public Function filterCountCheck2(ByRef tbl As ListObject, ByVal filterCol As Long, ByVal kwd As Long) As Long
filterCountCheck = 0
With tbl
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
Dim cnt As Long
.AutoFilter filterCol, kwd
filterCountCheck = .Columns(filterCol).SpecialCells(xlCellTypeVisible).Count - 1
End With
.ShowTotals = True
End With
End Function
Function IsFileCheck(ByVal FilePath As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
IsFileCheck = False
If fso.FileExists(FilePath) Then
IsFileCheck = True
End If
End Function
Public Sub test()
Dim r As Long, c As Long
Dim copysht As Worksheet
Dim targetRange As Range
Worksheets("Data").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "work"
Set copysht = Worksheets("work")
With copysht
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set targetRange = .Range(.Cells(1, 1), .Cells(r, c))
targetRange.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes
End With
End Sub
Public Sub test()
Dim cnt As Long
Dim step As Long
Dim FLG As Boolean
Dim payDate As Date
Dim testDate As Date
Dim dic As Object
Dim ws As Worksheet
Dim ans As Variant
Set dic = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Sheet2")
With ws
For cnt = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
dic.Add .Cells(cnt, 1).Value, .Cells(cnt, 2).Value
Next cnt
End With
testDate = Date + 40
If Day(testDate) >= 1 And Day(testDate) <= 14 Then
payDate = DateSerial(Year(testDate), Month(testDate), 25)
Else
payDate = DateSerial(Year(testDate), Month(testDate) + 1, 25)
End If
Select Case Format(Weekday(payDate), "ddd")
Case "Sun"
payDate = payDate + 1
step = 1
Case "Mon"
step = 1
Case "Tue", "Wed", "Thu", "Fri"
step = -1
Case "Sat"
step = -1
payDate = payDate - 1
End Select
Do While FLG = False
If dic.Exists(payDate) Then
payDate = payDate + step
Else
If Format(Weekday(payDate), "ddd") = "Sun" Or _
Format(Weekday(payDate), "ddd") = "Sat" Then
payDate = payDate + step
Else
FLG = True
End If
End If
Loop
Debug.Print payDate
End Sub
Public Sub test500()
Dim cn As Object, rs As Object, rst As Object
Dim i As Long, lastRow As Long
Dim tableName As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lst1 As ListObject
Dim lst2 As ListObject
Dim Rng1 As Range
Dim Rng2 As Range
Dim add1 As String
Dim add2 As String
Set wb1 = Workbooks("before.xlsm")
Set wb2 = Workbooks("after.xlsm")
Set ws1 = wb1.Worksheets("test")
Set ws2 = wb2.Worksheets("test")
Set lst1 = ws1.ListObjects(1)
Set lst2 = ws2.ListObjects(1)
Set Rng1 = lst1.Range
Set Rng2 = lst2.Range
add1 = Rng1.Address
add2 = Rng2.Address
add1 = Replace(add1, "$", "")
add2 = Replace(add2, "$", "")
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
tableName = "test$"
Dim DbPath As String
Dim DbPath1 As String
Dim DbPath2 As String
Dim strCon As String
Dim strSQL As String
DbPath = "C:\Users\menta\Desktop\vba_test\backup\test\after.xlsm"
strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
cn.Open strCon
' strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
' Con.Open strCon
' strSQL = "UPDATE [after.xlsm].[test$" & add1 & "] AS T INNER JOIN [before.xlsm].[test$" & add2 & "] AS S ON T.ItemCD = S.ItemCD " & _
' "SET T.EcCubeNum = S.EcCubeNum, " & _
' "T.EcCubeSetNum = S.EcCubeSetNum " & _
' "WHERE T.ItemCD = 'BNI01-10-0150-SET-RC-10b';"
DbPath1 = "C:\Users\menta\Desktop\vba_test\backup\test\after.xlsm"
DbPath2 = "C:\Users\menta\Desktop\vba_test\backup\test\before.xlsm"
' strSQL = "select * from [after.xlsm].[test$" & add1 & "] AS T INNER JOIN [before.xlsm].[test$" & add2 & "] AS S ON T.ItemCD = S.ItemCD WHERE T.ItemCD = 'BNI01-10-0150-SET-RC-10b';"
strSQL = "SELECT T1.ItemCD FROM [" & DbPath1 & "].[test$" & add1 & "] AS T1 INNER JOIN [" & DbPath2 & "].[test$" & add2 & "] AS S1 ON T1.ItemCD = S1.ItemCD WHERE T1.ItemCD = 'BNI01-10-0150-SET-RC-10b'"
'ok strSQL = "SELECT * FROM [" & DbPath1 & "].[test$" & add1 & "]"
rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
' cn.Execute strSQL
i = 1
Do Until rs.EOF
Debug.Print rs!Fields(S1.ItemCD)
rs.MoveNext
i = i + 1
Loop
' --- データベース接続を閉じる ---
cn.Close
Set cn = Nothing
MsgBox "更新完了"
End Sub
Public Sub test500()
Const adOpenKeyset As Long = 1
Const adLockReadOnly As Long = 1
Const adOpenStatic As Long = 2
Const adLockOptimistic As Long = 3
Dim cn As Object, rs As Object, rst As Object
Dim i As Long, lastRow As Long
Dim tablename As String
Dim nwb As Workbook
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim nws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim tgt As Worksheet
Dim lst1 As ListObject
Dim lst2 As ListObject
Dim v As Variant
Dim s As Variant
Dim flg As Boolean
Set nwb = ThisWorkbook
Set wb1 = Workbooks("before.xlsm")
Set wb2 = Workbooks("after.xlsm")
Set nws = nwb.Worksheets("tbl")
Set ws1 = wb1.Worksheets("test")
Set ws2 = wb2.Worksheets("test")
Set lst1 = ws1.ListObjects(1)
' Set lst2 = ws2.ListObjects(1)
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Dim DbPath As String
Dim strCon As String
Dim strSQL As String
DbPath = ThisWorkbook.Path & "\after.xlsm"
'strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" 'SELECT時
strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0 xml;HDR=Yes"";" 'UPDATE時
cn.Open strCon
flg = False
With wb2
Dim st As Worksheet
For Each st In .Worksheets
If st.Name = "cpy" Then
flg = True
Exit For
End If
Next st
If Not flg Then
.Worksheets.Add after:=Worksheets(Worksheets.Count)
.Worksheets(Worksheets.Count).Name = "cpy"
End If
Set tgt = Worksheets("cpy")
End With
With nws
ReDim v(1 To .ListObjects(1).ListRows.Count)
For i = 2 To .ListObjects(1).ListRows.Count + 1
v(i - 1) = .Cells(i, 1).Value
Next i
End With
For Each s In v
With lst1
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
Dim cnt As Long
.AutoFilter 2, s
End With
tgt.Cells.Clear
.Range.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
'tgt.Range("A1").PasteSpecial Paste:=xlPasteValues
'strSQL = "SELECT * FROM [" & DbPath & "].[cpy$]"
'rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
'i = 1
'Do Until rs.EOF
' Debug.Print rs.Fields("No") & " : " & rs.Fields("ParentCD") & " : " & rs.Fields("ItemCD") & " : " & rs.Fields("PageTitle")
' rs.MoveNext
' i = i + 1
'Loop
'ok strSQL = "UPDATE [" & tablename & "] SET [" & updateColumn & "] = '" & updateValue & "' WHERE [" & whereColumn & "] = '" & whereValue & "'"
'ok strSQL = "UPDATE [test$] SET [EcCubeNum] = '更新後の値' WHERE [ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok strSQL = "UPDATE [test$] AS T SET T.[EcCubeNum] = '更新後の値' WHERE T.[ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
strSQL = "UPDATE [test$] AS T INNER JOIN [cpy$] AS S ON T.[ItemCD] = S.[ItemCD] " & _
"SET T.[EcCubeNum] = S.[EcCubeNum], " & _
"T.[EcCubeSetNum] = S.[EcCubeSetNum], " & _
"T.[PageTitle] = S.[PageTitle];"
rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
'rs.Close 'SELECT文ループ時
End With
Next s
MsgBox "complete"
' cn.Close
' Set cn = Nothing
' rs.Close
' Set rs = Nothing
End Sub
Option Explicit
Public Sub test500()
Const adOpenKeyset As Long = 1
Const adLockReadOnly As Long = 1
Const adOpenStatic As Long = 2
Const adLockOptimistic As Long = 3
'------------------------------------------------------------
Dim con As Object
Dim rst As Object
Dim checkBook As Workbook
Dim baseBook As Workbook
Dim tempBook As Workbook
Dim lastBook As Workbook
Dim memberListSheet As Worksheet
Dim tempSheet As Worksheet
Dim copySheet As Worksheet
Dim lastSheet As Worksheet
Dim filePath As String
Dim code As String
Dim section As String
Dim checkFilePath As String
Dim strCon As String
Dim strSQL As String
Dim mList As Variant
Dim m As Variant
Dim i As Long, lastRow As Long
Dim x As Long, y As Long
filePath = ThisWorkbook.Path & "\"
Set memberListSheet = ThisWorkbook.Worksheets("tbl")
Call memberTableCreate(memberListSheet, mList)
' Set baseBook = Workbooks.Open(filePath & "\temp\template.xlsm", UpdateLinks:=0)
' With baseBook
' Dim flg As Boolean
' Dim sh As Worksheet
' flg = False
' For Each sh In .Worksheets
' If sh.Name = "copy" Then
' flg = True
' Exit For
' End If
' Next sh
'
' If Not flg Then
' .Worksheets.Add after:=Worksheets(Worksheets.Count)
' .Worksheets(Worksheets.Count).Name = "copy"
' End If
'
' .Save
' .Close
' End With
' Set baseBook = Nothing
Set con = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & filePath & "\temp\template.xlsm" & ";Extended Properties=""Excel 12.0 xml;HDR=Yes"";"
con.Open strCon
Dim filterCol As Long: filterCol = 2
For i = LBound(mList, 1) To UBound(mList, 1)
code = mList(i, 0)
section = mList(i, 1)
checkFilePath = filePath & section & "\Archive\" & code & ".xlsm"
Set tempBook = Workbooks.Open(filePath & "\temp\template.xlsm", UpdateLinks:=0)
Set tempSheet = tempBook.Worksheets("test")
Set copySheet = tempBook.Worksheets("copy")
' Call filterSet(tempSheet, filterCol, code)
If Dir(checkFilePath) <> "" Then
Set lastBook = Workbooks.Open(checkFilePath, UpdateLinks:=0)
Set lastSheet = lastBook.Worksheets("test")
Set lastSheet = lastBook.Worksheets("test")
x = filterDataCount(tempSheet, filterCol, code)
y = filterDataCount(lastSheet, filterCol, code)
If x > 0 And y > 0 Then
With lastSheet.ListObjects(1)
copySheet.Cells.Clear
.Range.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy copySheet.Range("A1")
strSQL = "UPDATE [test$] AS T INNER JOIN [copy$] AS S ON T.[ItemCD] = S.[ItemCD] " & _
"SET T.[EcCubeNum] = S.[EcCubeNum], " & _
"T.[EcCubeSetNum] = S.[EcCubeSetNum], " & _
"T.[PageTitle] = S.[PageTitle];"
rst.Open strSQL, con, adOpenStatic, adLockOptimistic
End With
End If
End If
Next i
'For Each m In mList
' With lst1
' If .ShowTotals = True Then
' .ShowTotals = False
' End If
'
' If .AutoFilter.FilterMode = True Then
' .AutoFilter.ShowAllData
' End If
'
' With .Range
' Dim cnt As Long
' .AutoFilter 2, s
' End With
'
' tgt.Cells.Clear
' .Range.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
'tgt.Range("A1").PasteSpecial Paste:=xlPasteValues
'strSQL = "SELECT * FROM [" & DbPath & "].[cpy$]"
'rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
'i = 1
'Do Until rs.EOF
' Debug.Print rs.Fields("No") & " : " & rs.Fields("ParentCD") & " : " & rs.Fields("ItemCD") & " : " & rs.Fields("PageTitle")
' rs.MoveNext
' i = i + 1
'Loop
'ok strSQL = "UPDATE [" & tablename & "] SET [" & updateColumn & "] = '" & updateValue & "' WHERE [" & whereColumn & "] = '" & whereValue & "'"
'ok strSQL = "UPDATE [test$] SET [EcCubeNum] = '更新後の値' WHERE [ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok strSQL = "UPDATE [test$] AS T SET T.[EcCubeNum] = '更新後の値' WHERE T.[ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
' strSQL = "UPDATE [test$] AS T INNER JOIN [cpy$] AS S ON T.[ItemCD] = S.[ItemCD] " & _
' "SET T.[EcCubeNum] = S.[EcCubeNum], " & _
' "T.[EcCubeSetNum] = S.[EcCubeSetNum], " & _
' "T.[PageTitle] = S.[PageTitle];"
'
' rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
'rs.Close 'SELECT文ループ時
' End With
' Next m
' DbPath = ThisWorkbook.Path & "\after.xlsm"
' 'strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" 'SELECT時
' strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0 xml;HDR=Yes"";" 'UPDATE時
' cn.Open strCon
' flg = False
' With wb2
' Dim st As Worksheet
' For Each st In .Worksheets
' If st.Name = "cpy" Then
' flg = True
' Exit For
' End If
' Next st
'
' If Not flg Then
' .Worksheets.Add after:=Worksheets(Worksheets.Count)
' .Worksheets(Worksheets.Count).Name = "cpy"
' End If
' Set tgt = Worksheets("cpy")
' End With
' For Each m In mList
' With lst1
' If .ShowTotals = True Then
' .ShowTotals = False
' End If
'
' If .AutoFilter.FilterMode = True Then
' .AutoFilter.ShowAllData
' End If
'
' With .Range
' Dim cnt As Long
' .AutoFilter 2, m
' End With
'
' tgt.Cells.Clear
' .Range.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
'tgt.Range("A1").PasteSpecial Paste:=xlPasteValues
'strSQL = "SELECT * FROM [" & DbPath & "].[cpy$]"
'rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
'i = 1
'Do Until rs.EOF
' Debug.Print rs.Fields("No") & " : " & rs.Fields("ParentCD") & " : " & rs.Fields("ItemCD") & " : " & rs.Fields("PageTitle")
' rs.MoveNext
' i = i + 1
'Loop
'ok strSQL = "UPDATE [" & tablename & "] SET [" & updateColumn & "] = '" & updateValue & "' WHERE [" & whereColumn & "] = '" & whereValue & "'"
'ok strSQL = "UPDATE [test$] SET [EcCubeNum] = '更新後の値' WHERE [ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok strSQL = "UPDATE [test$] AS T SET T.[EcCubeNum] = '更新後の値' WHERE T.[ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
' strSQL = "UPDATE [test$] AS T INNER JOIN [cpy$] AS S ON T.[ItemCD] = S.[ItemCD] " & _
' "SET T.[EcCubeNum] = S.[EcCubeNum], " & _
' "T.[EcCubeSetNum] = S.[EcCubeSetNum], " & _
' "T.[PageTitle] = S.[PageTitle];"
'
' rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
'
' 'rs.Close 'SELECT文ループ時
' End With
' Next m
'
' MsgBox "complete"
' cn.Close
' Set cn = Nothing
' rs.Close
' Set rs = Nothing
End Sub
Public Function filterCountCheck(ByRef tbl As ListObject, ByVal filterCol As Long, ByVal kwd As Long) As Long
Dim visibleRange As Range
Dim hasData As Boolean
If Application.ScreenUpdating = True Then
Application.ScreenUpdating = False
End If
With tbl
' If .ShowTotals = True Then
' .ShowTotals = False
' End If
'
' If .AutoFilter.FilterMode = True Then
' .AutoFilter.ShowAllData
' End If
' With .Range
' Dim cnt As Long
' .AutoFilter filterCol, kwd
' filterCountCheck = .Columns(filterCol).SpecialCells(xlCellTypeVisible).Count - 1
' End With
' Debug.Print .DataBodyRange.SpecialCells(xlCellTypeVisible).Rows.Count
On Error Resume Next
Set visibleRange = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If visibleRange Is Nothing Then
filterCountCheck = 0
Else
filterCountCheck = .DataBodyRange.SpecialCells(xlCellTypeVisible).Rows.Count
End If
' .ShowTotals = True
End With
End Function
Public Sub testa()
Dim list As Variant
Dim r As Long
Dim i As Long
Dim max As Long
Dim targetRange As Range
With ThisWorkbook.Worksheets("Sheet2")
max = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim list(max - 1)
For i = 1 To max
list(i - 1) = .Cells(i, 1).Value
Next i
End With
With Worksheets("boltset").ListObjects(1)
For i = LBound(list) To UBound(list)
With .Range.CurrentRegion
.AutoFilter 2, list(i)
On Error Resume Next
Set targetRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
If targetRange Is Nothing Then
Debug.Print "nashi"
Else
targetRange.Delete shift:=xlUp
End If
Next i
.Range.AutoFilter 2
End With
End Sub
Private Sub UserForm_Initialize()
Dim itemWS As Worksheet
Dim regWS As Worksheet
Dim listobj As ListObject
Dim cb As Object
Dim i As Long
Dim j As Long
Dim lastRow As Long
Set itemWS = Worksheets("items")
Set regWS = Worksheets("regsheet")
With itemWS
j = 1
For Each listobj In .ListObjects
Me.Controls("ComboBox" & j).Clear
For i = 2 To listobj.DataBodyRange.Rows.Count
Me.Controls("ComboBox" & j).AddItem listobj.Range.Item(i)
Next i
j = j + 1
Next listobj
End With
End Sub
フォーム
Option Explicit
Dim EventEnabled As Boolean
' ユーザーフォーム初期化
Private Sub UserForm_Initialize()
EventEnabled = True
Call Sheet1.LoadData
Call LoadIdList
End Sub
' 更新ボタン処理
Private Sub CommandButton1_Click()
' If CheckFields Then
' Dim p As Person: Set p = New Person
'
' p.Name = TextBox1.Text
' p.Birthday = TextBox2.Value
' p.Gender = "女"
' If OptionButton1.Value = True Then p.Gender = "男"
' p.Active = CheckBox1.Value
'
' If ComboBox1.Value = "New" Then
' p.Id = Sheet7.MaxId + 1
' Call Sheet7.AddPerson(p)
' Else
' p.Id = ComboBox1.Value
' Call Sheet7.UpdatePerson(p)
' End If
'
' Call LoadFields(p.Id)
' Call LoadIdList
'
' End If
End Sub
' ユーザーフォーム閉じる
Private Sub CommandButton2_Click()
Unload Me
End Sub
' コンボボックス変更時の処理切り分け
' (ProjectCodeが選択時、"New"選択時の処理切り分け)
Private Sub ComboBox1_Change()
With ComboBox1
If IsValidId Then
If .Value = "New" Then
Call AllClearFields
Call LoadYmd(.Value)
Else
Call LoadYmd(.Value)
Call LoadFields(.Value)
End If
Else
Call AllClearFields
End If
End With
End Sub
Private Sub ComboBox2_Change()
If Not EventEnabled Then Exit Sub
If Me.ComboBox3.Value <> "" Or IsNull(Me.ComboBox3.Value) Then
If Me.ComboBox4.Value <> "" Or IsNull(Me.ComboBox4.Value) Then
Call LoadDay(True)
End If
End If
End Sub
Private Sub ComboBox3_Change()
If Not EventEnabled Then Exit Sub
If Me.ComboBox4.Value <> "" Or IsNull(Me.ComboBox4.Value) Then
Call LoadDay(True)
End If
End Sub
Private Sub ComboBox5_Change()
If Not EventEnabled Then Exit Sub
If Me.ComboBox6.Value <> "" Or IsNull(Me.ComboBox6.Value) Then
If Me.ComboBox7.Value <> "" Or IsNull(Me.ComboBox7.Value) Then
Call LoadDay(True)
End If
End If
End Sub
Private Sub ComboBox6_Change()
If Not EventEnabled Then Exit Sub
If Me.ComboBox7.Value <> "" Or IsNull(Me.ComboBox7.Value) Then
Call LoadDay(True)
End If
End Sub
' コンボボックスへのテーブルIDリスト読み込み
Private Sub LoadIdList()
With Sheet1.ListObjects(1)
If .ListRows.Count > 1 Then
Dim lists As Variant: lists = .ListColumns(2).DataBodyRange
ComboBox1.List = lists
End If
End With
ComboBox1.AddItem "New"
End Sub
' **
' コンボボックスのProjectCodeが空欄でないかどうか
' (ProjectCodeが空欄でない、または"New"かどうか)
' @return {boolean}
Private Property Get IsValidId() As Boolean
IsValidId = False
With ComboBox1
If (Sheet1.isExists(.Value)) Or (.Value = "New") Then
IsValidId = True
End If
End With
End Property
' 指定myProjectCDでのレコードデータの呼び出し
' @param {myProjectCD：String} 呼び出すレコードデータのmyProjectCD値
Private Sub LoadFields(ByVal myProjectCD As String)
With Sheet1.pjt(myProjectCD)
TextBox1.Value = .projectName
TextBox2.Value = .Amount
ComboBox1.Value = .projectCode
ComboBox2.Value = Year(.startDate)
ComboBox3.Value = Month(.startDate)
ComboBox4.Value = Day(.startDate)
ComboBox5.Value = Year(.endDate)
ComboBox6.Value = Month(.endDate)
ComboBox7.Value = Day(.endDate)
ComboBox8.Value = .periodOfMonth
End With
End Sub
Private Sub LoadYmd(ByVal myProjectCD As String)
Dim i As Integer
Dim starty As Long
Dim endy As Long
Dim startm As Long
Dim endm As Long
Dim startd As Long
Dim endd As Long
EventEnabled = False
For i = 2 To 7
Me("ComboBox" & i).Clear
Next i
starty = Year(Date) - 9
endy = Year(Date) + 9
startm = 1
endm = 12
startd = 1
endd = 31
For i = starty To endy
Me.ComboBox2.AddItem i
Me.ComboBox5.AddItem i
Next i
For i = startm To endm
Me.ComboBox3.AddItem i
Me.ComboBox6.AddItem i
Next i
For i = startd To endd
Me.ComboBox4.AddItem i
Me.ComboBox7.AddItem i
Next i
Me.ComboBox2.Value = Year(Date)
Me.ComboBox5.Value = Year(Date)
Me.ComboBox3.Value = Month(Date)
Me.ComboBox6.Value = Month(Date)
Me.ComboBox4.Value = startd
Me.ComboBox7.Value = startd
If myProjectCD <> "New" Then
With Sheet1.pjt(myProjectCD)
Me.ComboBox2.Value = Year(.startDate)
Me.ComboBox3.Value = Month(.startDate)
Me.ComboBox4.Value = Day(.startDate)
Me.ComboBox5.Value = Year(.endDate)
Me.ComboBox6.Value = Month(.endDate)
Me.ComboBox7.Value = Day(.endDate)
End With
Call LoadDay(False)
End If
EventEnabled = True
End Sub
Private Sub LoadDay(ByVal FLG As Boolean)
Dim i As Integer
Dim selectYear As Long
Dim selectMonth As Long
Dim tempDay As Long
Dim lastDay As Long
selectYear = Me.ComboBox2.Value
selectMonth = Me.ComboBox3.Value
tempDay = Me.ComboBox4.Value
lastDay = Day(DateSerial(selectYear, selectMonth + 1, 1) - 1)
Me.ComboBox4.Clear
For i = 1 To lastDay
Me.ComboBox4.AddItem i
Next i
If FLG Then
If tempDay > lastDay Then tempDay = 1
End If
Me.ComboBox4.Value = tempDay
selectYear = Me.ComboBox5.Value
selectMonth = Me.ComboBox6.Value
tempDay = Me.ComboBox7.Value
lastDay = Day(DateSerial(selectYear, selectMonth + 1, 1) - 1)
Me.ComboBox7.Clear
For i = 1 To lastDay
Me.ComboBox7.AddItem i
Next i
If FLG Then
If tempDay > lastDay Then tempDay = 1
End If
Me.ComboBox7.Value = tempDay
End Sub
' **
' 性別文字列(男、女)をもとにオプションボタンを設定
' @param {myGender：String} 性別文字列
Private Sub SetGender(ByVal myGender As String)
' OptionButton2.Value = True
' If myGender = "男" Then OptionButton1.Value = True
End Sub
' 各コントロールの値をクリア
Private Sub AllClearFields()
Dim i As Long
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
EventEnabled = False
For i = 2 To 8
Me("ComboBox" & i).Value = ""
Me("ComboBox" & i).Clear
Next i
EventEnabled = True
End Sub
' **
' 各コントロール値が正しく入力されているかどうかを判定する
'
' @return {Boolean}
'
Private Function CheckFields() As Boolean
' CheckFields = True
'
' If Not IsValidId Then
' MsgBox "「ID」は1以上IDの最大値以下の数値または""New""を入力してください", vbInformation
' CheckFields = False
' End If
'
' If Len(TextBox1.Text) = 0 Then
' MsgBox "「名前」に入力してください", vbInformation
' CheckFields = False
' End If
'
' If IsDate(TextBox2.Value) Then
' MsgBox "「誕生日」には日付を入力してください", vbInformation
' CheckFields = False
' End If
End Function
標準モジュール
Option Explicit
Public Sub fOpen()
UserForm1.Show
End Sub
Public Sub fileCreateA()
If fileCheck Then
If MsgBox("既に編集ファイルがあります。削除してもいいですか？", vbYesNo) = vbYes Then
Call editFileDelete
Else
Exit Sub
End If
End If
Call fileCreate(1)
End Sub
Public Sub fileCreateB()
If fileCheck Then
If MsgBox("既に編集ファイルがあります。削除してもいいですか？", vbYesNo) = vbYes Then
Call editFileDelete
Else
Exit Sub
End If
End If
Call fileCreate(2)
End Sub
Public Sub editFileDelete()
Application.DisplayAlerts = False
Worksheets("EditSheet").Delete
Application.DisplayAlerts = True
End Sub
Public Sub fileCreate(ByVal n As Long)
Dim copySheet As Worksheet
Dim editSheet As Worksheet
On Error Resume Next
Set copySheet = Worksheets("template" & n)
On Error GoTo 0
If copySheet Is Nothing Then
MsgBox "シート '" & copySheet & "' が見つかりません。", vbCritical
Exit Sub
End If
copySheet.Visible = xlSheetVisible
copySheet.Copy After:=Worksheets(Worksheets.Count)
Set editSheet = Worksheets(Worksheets.Count)
editSheet.Name = "EditSheet"
copySheet.Visible = xlSheetHidden
End Sub
Public Function fileCheck() As Boolean
Dim ws As Worksheet
fileCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "EditSheet" Then fileCheck = True
Next ws
End Function
クラス
Option Explicit
Public Id As Long
Public projectCode As String
Public projectName As String
Public Amount As Long
Public startDate As Date
Public endDate As Date
Public periodOfMonth As Long
'**
' Pjtクラスのインスタンスへの値設定
'
' @param myRange{Range}
'
Public Sub Initialize(ByVal myRange As Range)
Id = myRange(eId).Value
projectCode = myRange(eCode).Value
projectName = myRange(eName).Value
Amount = myRange(eAmount).Value
startDate = myRange(eStartDate).Value
endDate = myRange(eEndDate).Value
periodOfMonth = myRange(eMonth).Value
End Sub
'**
' Projectクラスの年齢を取得
'
' @param myRange{Range}
'
'Public Property Get periodOfMonth() As Long
' Dim myAge As Long
' myAge = DateDiff("m", StartDate, EndDate)
' periodOfMonth = myAge
'End Property
シート1(PROJECT)
Option Explicit
Enum eFieldSheet1
eId = 1
eCode
eName
eAmount
eStartDate
eEndDate
eMonth
End Enum
Public pjt As Collection
Public dic As Object
Public MaxId As Long
' テーブルのデータをpjtコレクションとして格納
Public Sub LoadData()
Set dic = CreateObject("Scripting.Dictionary")
Set pjt = New Collection
With ListObjects(1)
Dim myRow As ListRow
For Each myRow In .ListRows
Dim p As Projects: Set p = New Projects
p.Initialize myRow.Range
pjt.Add p, p.projectCode
dic.Add p.projectCode, p.Id
Next myRow
MaxId = .ListRows.Count
End With
End Sub
'**
' Pjtコレクションのデータをテーブルに展開
Public Sub ApplyData()
With ListObjects(1)
If .ListRows.Count > 0 Then
.DataBodyRange.EntireRow.Delete
End If
Dim p As Projects
For Each p In pjt
.ListRows.Add.Range = Array(p.Id, p.projectCode, p.projectName, p.Amount, p.startDate, p.endDate, p.periodOfMonth, p.Active)
Next p
MaxId = .ListRows.Count
End With
End Sub
'**
' PjtコレクションのProjectsオブジェクトを更新
'
' @param p{Projects} 更新するProjectsオブジェクト
Public Sub UpdateProjects(p As Projects)
With pjt(p.Id)
.Id = p.Id
.projectCode = p.projectCode
.projectName = p.projectName
.Amount = p.Amount
.startDate = p.startDate
.endDate = p.endDate
.periodOfMonth = p.periodOfMonth
End With
Call ApplyData
End Sub
'**
' PersonsコレクションのPersonオブジェクトを追加
'
' @param p{Person} 追加するPersonオブジェクト
Public Sub AddProjects(pjt As Projects)
' Pjt.Add p, CStr(p.Id)
' Call ApplyData
End Sub
Function isExists(ByVal pCode As String) As Boolean
isExists = False
If dic.Exists(pCode) Then
If dic.Item(pCode) <= MaxId Then
isExists = True
End If
End If
End Function
Public Sub test500()
Const adOpenKeyset As Long = 1
Const adLockReadOnly As Long = 1
Const adOpenStatic As Long = 2
Const adLockOptimistic As Long = 3
Dim cn As Object, rs1 As Object, rs2 As Object
Dim i As Long, j As Long
Dim tablename As String
Dim nws As Worksheet
Dim lst As ListObject
Set nws = Worksheets("dat")
Set cn = CreateObject("ADODB.Connection")
Set rs1 = CreateObject("ADODB.Recordset")
Dim DbPath As String
Dim strCon As String
Dim strSQL As String
DbPath = ThisWorkbook.Path & "\ORDERS_DETAILS.xlsm"
strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0 xml;HDR=Yes"";" 'UPDATE時
cn.Open strCon
strSQL = "SELECT OrderId, CheckOut FROM [" & DbPath & "].[dat$] GROUP BY OrderId, CheckOut"
rs1.Open strSQL, cn, adOpenKeyset, adLockReadOnly
i = 1
Do Until rs1.EOF
strSQL = "SELECT OrderId, CheckOut FROM [" & DbPath & "].[dat$] GROUP BY OrderId, CheckOut"
'strSQL = "SELECT * FROM [" & DbPath & "].[dat$] WHERE OrderId = " & rs1.Fields("OrderId")
rs2.Open strSQL, cn, adOpenKeyset, adLockReadOnly
Do Until rs2.EOF
Debug.Print rs2.Fields("No") & " : " & rs2.Fields("Meisai")
rs2.MoveNext
Loop
rs1.MoveNext
i = i + 1
Loop
'ok strSQL = "UPDATE [" & tablename & "] SET [" & updateColumn & "] = '" & updateValue & "' WHERE [" & whereColumn & "] = '" & whereValue & "'"
'ok strSQL = "UPDATE [test$] SET [EcCubeNum] = '更新後の値' WHERE [ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok strSQL = "UPDATE [test$] AS T SET T.[EcCubeNum] = '更新後の値' WHERE T.[ItemCD] = 'BNI01-10-0150-SET-RC-10a'"
'ok rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
'
' rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
rs2.Close
rs1.Close 'SELECT文ループ時
MsgBox "complete"
' cn.Close
' Set cn = Nothing
' rs.Close
' Set rs = Nothing
End Sub
Public Sub test502()
Dim i As Long
Dim row As Long
Dim regPrice As Long
Dim thisRow As Long
Dim dic As Object
Dim cd As String
Dim key As Variant
Dim ws As Worksheet
Set ws = Worksheets("test")
Set dic = CreateObject("Scripting.Dictionary")
With ws
row = .Cells(.Rows.Count, 1).End(xlUp).row
For i = 2 To row
cd = .Cells(i, 1).Value
If cd <> "" Then
thisRow = .Rows(i).row
regPrice = 0
If dic.Exists(cd) Then
regPrice = .Cells(dic.Item(cd), 6).Value
If .Cells(thisRow, 6).Value > regPrice Then
dic(cd) = thisRow
End If
Debug.Print dic(cd)
Else
dic.Add cd, thisRow
End If
End If
Next i
For Each key In dic
Debug.Print key, dic(key)
Next key
End With
End Sub
' ブック 開いてるかチェック
' @param {bName : string}
' @return {sheetCheck : Boolean}
'------------------------------------------------------------------
Function bookOpenCheck(bName As String) As Boolean
Dim bk As Workbook
For Each bk In Workbooks
If bk.Name = bName Then
bookOpenCheck = True
Exit For
End If
Next
bookOpenCheck = False
End Function
' シート 有無チェック
' @param {sName : string}
' @return {sheetCheck : Boolean}
'------------------------------------------------------------------
Function sheetCheck(sName As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = sName Then
sheetCheck = True
Exit Function
End If
Next
sheetCheck = False
End Function
' リスト作成
' @param {Rng : Range}
' @return {getConfig : Object}
'------------------------------------------------------------------
Function getConfig(ByRef Rng As Range) As Object
Set getConfig = CreateObject("Scripting.Dictionary")
Dim i As Long
With Rng
For i = 2 To .Rows.Count
getConfig.Add .Cells(i, 1).Value, .Cells(i, 2).Value
Next i
End With
End Function
' テンプレートブック初期化
'
'------------------------------------------------------------------
Sub initializeTemplate(ByRef wb As Workbook)
Dim i As Long
Dim j As Long
Dim c As Variant
Dim del_starting_point1 As Long
Dim del_starting_point2 As Long
Dim deleteColumns() As Variant
With wb
'DAT クリア処理
With .Worksheets("DAT")
deleteColumns = Array("D", "F", "H", "J")
del_starting_point1 = 8
del_starting_point2 = 27
.Range("D2").Value = ""
For Each c In deleteColumns
For i = del_starting_point1 To del_starting_point1 + 12 - 1
.Range(c & i).ClearContents
Next i
For i = del_starting_point2 To del_starting_point2 + 12 - 1
.Range(c & i).ClearContents
Next i
Next c
End With
'LIST1 クリア処理
With .Worksheets("LIST1")
With .ListObjects(1)
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
.ShowTotals = True
End With
End With
'LIST2 クリア処理
With .Worksheets("LIST2")
With .ListObjects(1)
If .ShowTotals = True Then
.ShowTotals = False
End If
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
.ShowTotals = True
End With
End With
'TABLE クリア処理
With .Worksheets("TABLE")
deleteColumns = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L")
del_starting_point1 = 3
For Each c In deleteColumns
For i = del_starting_point1 To del_starting_point1 + 17 - 1
.Range(c & i).ClearContents
Next i
Next c
End With
'ALL クリア処理
With .Worksheets("ALL")
deleteColumns = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
del_starting_point1 = 3
For Each c In deleteColumns
For i = del_starting_point1 To del_starting_point1 + 23 - 1
.Range(c & i).ClearContents
Next i
Next c
End With
End With
End Sub
' ファイル作成
'
'------------------------------------------------------------------
Sub tempFileEdit(ByRef wb As Workbook, ByVal mbr As String)
Dim i As Long
Dim j As Long
Dim n As Variant
Dim c As Variant
Dim del_starting_point1 As Long
Dim del_starting_point2 As Long
Dim deleteColumns() As Variant
With wb
'DAT クリア処理
With .Worksheets("DAT")
deleteColumns = Array("E", "G", "I", "K")
del_starting_point1 = 8
del_starting_point2 = 27
.Range("D2").Value = mbr
For Each c In deleteColumns
With .Range(c & del_starting_point1 & ":" & c & del_starting_point1 + 12 - 1)
.Formula = "=RANDBETWEEN(1000,9999)"
.Value = .Value
End With
With .Range(c & del_starting_point2 & ":" & c & del_starting_point2 + 12 - 1)
.Formula = "=RANDBETWEEN(1000,9999)"
.Value = .Value
End With
'列番号-1 → 列名取得
n = Split(.Cells(1, .Cells(1, c).Column - 1).Address(1, 0), "$")(0)
With .Range(n & del_starting_point1 & ":" & n & del_starting_point1 + 7 - 1)
.Formula = "=" & c & del_starting_point1
.Interior.ThemeColor = 2
.Interior.TintAndShade = 0.8
End With
With .Range(n & del_starting_point2 & ":" & n & del_starting_point2 + 7 - 1)
.Formula = "=" & c & del_starting_point2
.Value = .Value
.Interior.ThemeColor = 2
.Interior.TintAndShade = 0.8
End With
Next c
End With
'TABLE クリア処理
With .Worksheets("TABLE")
deleteColumns = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L")
del_starting_point1 = 3
For Each c In deleteColumns
With .Range(c & del_starting_point1 & ":" & c & del_starting_point1 + 17 - 1)
.Formula = "=RANDBETWEEN(100,999)"
.Value = .Value
End With
Next c
End With
'ALL クリア処理
With .Worksheets("ALL")
deleteColumns = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
del_starting_point1 = 3
For Each c In deleteColumns
With .Range(c & del_starting_point1 & ":" & c & del_starting_point1 + 23 - 1)
.Formula = "=RANDBETWEEN(100000,555555)"
.Value = .Value
End With
Next c
End With
End With
End Sub
Sub createFileSave(ByRef wb As Workbook, ByVal fName As String, ByVal path As String)
With wb
Application.DisplayAlerts = False
.SaveAs path & fName & ".xlsx"
Application.DisplayAlerts = True
End With
End Sub
Public Sub main()
If sheetCheck("config") = False Then
MsgBox "not config sheet"
Exit Sub
End If
Dim thisBook As Workbook
Dim tempBook As Workbook
Dim rngConfig As Range
Dim dicMember As Object
Set thisBook = ThisWorkbook
Set rngConfig = thisBook.Worksheets("member").Range("B2").CurrentRegion
Set dicMember = CreateObject("Scripting.Dictionary")
Set dicMember = getConfig(rngConfig)
Dim tempPath As String: tempPath = ThisWorkbook.path & "\temp"
Dim tmpName As String: tmpName = "template.xlsx"
Dim mbr As Variant
Dim sec As String
For Each mbr In dicMember.Keys
sec = dicMember.Item(mbr)
If bookOpenCheck(tmpName) = False Then
Set tempBook = Workbooks.Open(tempPath & "\" & tmpName, UpdateLinks:=0)
Call initializeTemplate(tempBook)
End If
Call createFileSave(tempBook, mbr, savePath)
Next
' Call memberTableCreate(memberListSheet, mList)
End Sub
Public Sub memberFileCreate()
Dim thisBook As Workbook
Dim tempBook As Workbook
Dim rngConfig As Range
Dim dicMember As Object
Set thisBook = ThisWorkbook
Set rngConfig = thisBook.Worksheets("member").Range("B2").CurrentRegion
Set dicMember = CreateObject("Scripting.Dictionary")
Set dicMember = getConfig(rngConfig)
Dim tempPath As String: tempPath = ThisWorkbook.path & "\temp"
Dim tmpName As String: tmpName = "template.xlsx"
Dim savePath As String
Dim mbr As Variant
Dim sec As String
Application.ScreenUpdating = False
For Each mbr In dicMember.Keys
sec = dicMember.Item(mbr)
savePath = ThisWorkbook.path & "\" & sec & "\Archive\"
If bookOpenCheck(tmpName) = False Then
Set tempBook = Workbooks.Open(tempPath & "\" & tmpName, UpdateLinks:=0)
Call tempFileEdit(tempBook, mbr)
End If
Call createFileSave(tempBook, mbr, savePath)
tempBook.Close
Set tempBook = Nothing
Next
Application.ScreenUpdating = True
MsgBox "complete"
End Sub
Public Sub dic()
Dim ws As Worksheet
Dim tbl As Range
Dim header As Range
Set ws = Worksheets("ikeikinset")
Set tbl = ws.ListObjects(1).Range.CurrentRegion
Set header = tbl.Rows(1)
Dim tb1_Name_Col As Object
Set tb1_Name_Col = CreateObject("Scripting.Dictionary")
tb1_Name_Col.Add "No", WorksheetFunction.Match(header.Cells.Item(1), header, 0)
tb1_Name_Col.Add "ParentCD", WorksheetFunction.Match(header.Cells.Item(2), header, 0)
tb1_Name_Col.Add "ItemCD", WorksheetFunction.Match(header.Cells.Item(3), header, 0)
tb1_Name_Col.Add "EcCubeNum", WorksheetFunction.Match(header.Cells.Item(4), header, 0)
tb1_Name_Col.Add "EcCubeSetNum", WorksheetFunction.Match(header.Cells.Item(5), header, 0)
tb1_Name_Col.Add "PageTitle", WorksheetFunction.Match(header.Cells.Item(6), header, 0)
tb1_Name_Col.Add "KikakuRank", WorksheetFunction.Match(header.Cells.Item(7), header, 0)
tb1_Name_Col.Add "ZeinukiTanka", WorksheetFunction.Match(header.Cells.Item(8), header, 0)
tb1_Name_Col.Add "ZeikomiTanka", WorksheetFunction.Match(header.Cells.Item(9), header, 0)
tb1_Name_Col.Add "BaseQuantity", WorksheetFunction.Match(header.Cells.Item(10), header, 0)
tb1_Name_Col.Add "ZeinukiSetPrice", WorksheetFunction.Match(header.Cells.Item(11), header, 0)
tb1_Name_Col.Add "SetPrice", WorksheetFunction.Match(header.Cells.Item(12), header, 0)
tb1_Name_Col.Add "DisplayFLG", WorksheetFunction.Match(header.Cells.Item(13), header, 0)
tb1_Name_Col.Add "Link", WorksheetFunction.Match(header.Cells.Item(14), header, 0)
End Sub
Sub mysub4()
Dim ws As Worksheet
Dim editCol As Object
Dim colArr As Variant
Dim v As Variant
Dim i As Long: i = 1
Dim r As Long
Set ws = Worksheets("history")
Set editCol = CreateObject("Scripting.Dictionary")
Set editCol = getEditColumns(ws, 30)
ReDim colArr(1 To editCol.Count)
For Each v In editCol
colArr(i) = v
i = i + 1
Next v
With ws
For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(r, editCol.Item("C")).Value = "=" & colArr(editCol.Item("D")) & r
.Cells(r, editCol.Item("G")).Value = "=" & colArr(editCol.Item("H")) & r
.Cells(r, editCol.Item("K")).Value = "=" & colArr(editCol.Item("L")) & r
Next r
End With
End Sub
Public Sub mysub5()
Dim ws As Worksheet
Dim tbl As Range
Dim listRow As listRow
Dim colMember As Collection
Set colMember = New Collection
Set ws = Worksheets("名簿")
With ws.ListObjects(1)
For Each listRow In .ListRows
Dim member As ListMember: Set member = New ListMember
member.Initialize listRow.Range
colMember.Add member, CStr(member.Id)
Next listRow
End With
Dim mbr As ListMember
For Each mbr In colMember
Dim val As Variant
'val = Array(mbr.Id, mbr.Name, mbr.Gender, mbr.Birthday, mbr.Active)
Debug.Print mbr.Id, mbr.Name
Next mbr
End Sub
Public Function getEditColumns(sh As Worksheet, ByVal colCnt As Long) As Object
Set getEditColumns = CreateObject("Scripting.Dictionary")
Dim i As Long
With sh
For i = 1 To colCnt
getEditColumns.Add Split(Columns(i).Address, "$")(2), i
Next i
End With
End Function
Public Sub mysub7()
Dim arr(1, 3) As Variant
Dim item1 As Variant
Dim item2 As Variant
Dim i As Long
item1 = Array("MATERIAL", 1, 2, 3)
item2 = Array("SUBCON", 4, 5, 6)
For i = 0 To 3
arr(0, i) = item1(i)
arr(1, i) = item2(i)
Next i
End Sub
VBAエディタで、[ツール] > [参照設定] から「Microsoft XML, v6.0」にチェックを入れます。
Dim httpReq As Object
Set httpReq = CreateObject("Msxml2.XMLHTTP60")
Dim url As String
' 実際のサイトとライブラリ名に合わせて変更してください
url = "https://<テナント名>.sharepoint.com/sites/<サイト名>/_api/web/lists/getbytitle('<ライブラリ名>')/items?$select=File/Name"
httpReq.Open "GET", url, False
' レスポンスの解析（例：ファイル名のみ取得）
Dim responseText As String
responseText = httpReq.ResponseText
' ここでJSON解析を行う
' 例: responseTextをパースして、各ファイル名を抽出する
MsgBox responseText ' サンプルの表示
Dim xmlHttp As Object
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.6.0")
url = https://{your_tenant}.sharepoint.com/sites/{site_name}/_api/web/lists/getbytitle('ライブラリ名')/items
siteUrl = "https://{your_tenant}.sharepoint.com/sites/{site_name}/"
xmlHttp.Open "GET", url, False
Dim xmlHttp As Object
Dim jsonResponse As Object
Dim listItems As Object
Dim item As Variant
Dim fileInfo As String
Dim siteUrl As String
Dim libraryTitle As String
Dim apiEndpoint As String
' SharePointサイトのURLとライブラリ名を指定します
siteUrl = "https://{your_tenant}.sharepoint.com/sites/{site_name}/" ' 例: https://contoso.sharepoint.com/sites/MySite/
libraryTitle = "ドキュメント" ' ライブラリの正確な名前を指定します
' REST APIエンドポイントを構築します
apiEndpoint = siteUrl & "_api/web/lists/getbytitle('" & libraryTitle & "')/items"
' XMLHTTPオブジェクトを作成します
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.6.0")
' GETリクエストを開きます
xmlHttp.Open "GET", apiEndpoint, False
' リクエストヘッダーを設定します
xmlHttp.setRequestHeader "Accept", "application/json;odata=verbose"
xmlHttp.setRequestHeader "Content-Type", "application/json;odata=verbose"
' サーバーにリクエストを送信します
xmlHttp.send
' ステータスを確認します (200は成功)
If xmlHttp.Status = 200 Then
' JSONレスポンスをStringとして取得します
Dim jsonString As String
jsonString = xmlHttp.responseText
' JSONをObjectに変換します (JsonConverterライブラリを使用する場合)
' 事前にJsonConverterのコードをVBAエディタに貼り付けておくか、参照設定で追加してください
' 例: Set jsonResponse = JsonConverter.ParseJson(jsonString)
' JsonConverterライブラリがない場合、手動でJSON解析を行うか、別ライブラリを利用する必要があります
' 以下はJsonConverterライブラリを利用する前提で記述します
' JsonConverterライブラリの取得方法は検索してください
' For more information on JSON parsing in VBA, search for "VBA JSON parser"
Set jsonResponse = JsonConverter.ParseJson(jsonString)
' 結果のリストアイテムを取得します
Set listItems = jsonResponse("d")("results")
' ファイル名一覧を表示します
For Each item In listItems
' FileLeafRefからファイル名を取得します
fileInfo = item("FileLeafRef")
Debug.
GetFolderByServerRelativeUrlは、SharePointのREST APIの一部であり、指定したサーバー相対URLに対応するフォルダーを取得するためのエンドポイントです。以下は、このエンドポイントの基本的な使用法の例です。
GET /_api/web/GetFolderByServerRelativeUrl('/sites/yoursite/Shared Documents/YourFolder')
この例では、/sites/yoursite/Shared Documents/YourFolderは目的のフォルダーのサーバー相対URLです。実際のサイトやフォルダーのパスに置き換えてください。
REST APIエンドポイントは通常、SharePointのサイトのURLの後に/_apiを追加してアクセスします。上記の例では、/sites/yoursiteはサイトのURLに相当します。
また、$selectクエリ パラメータを使用して、取得するプロパティを指定することができます。たとえば、次のようにして特定のプロパティだけを取得することができます。
GET /_api/web/GetFolderByServerRelativeUrl('/sites/yoursite/Shared Documents/YourFolder')?$select=Name,ServerRelativeUrl
これにより、NameとServerRelativeUrlプロパティのみが応答に含まれます。
このREST APIエンドポイントを利用する際には、通常、適切な認証と権限が必要です。認証トークンを含めるか、要求を行う前に適切な認証プロセスを実施することが重要です。
特定のフォルダ内に存在するファイルを取得するためには、/_api/web/getfolderbyserverrelativeurlエンドポイントを使用してフォルダの情報を取得し、その後に取得したフォルダ内のファイル一覧を取得する必要があります。以下は基本的な手順です。
フォルダのサーバー相対URLを取得:
取得したいフォルダのサーバー相対URLを指定して、getfolderbyserverrelativeurlエンドポイントを使用します。
http
GET https://contoso.sharepoint.com/sites/mysite/_api/web/getfolderbyserverrelativeurl('/sites/mysite/Shared Documents/FolderName')
ここで、FolderNameは取得したいフォルダの名前に置き換えます。
取得したフォルダ内のファイル一覧を取得:
取得したフォルダの情報から、filesプロパティを使用してフォルダ内のファイル一覧を取得します。
http
GET https://contoso.sharepoint.com/sites/mysite/_api/web/getfolderbyserverrelativeurl('/sites/mysite/Shared Documents/FolderName')/files
このリクエストにより、指定したフォルダ内のファイル一覧が得られます。
注意事項:
リクエストを実行するには、適切な認証が必要です。通常は、Azure ADアクセストークンを使用して認証を行います。
取得したファイル一覧には、各ファイルのメタデータ（名前、作成日時、変更日時など）が含まれます。
フォルダ内に大量のファイルがある場合、ページネーションを考慮して取得する必要があります。
これにより、指定したサーバー相対URLのフォルダ内に存在するファイル一覧を取得できます。
SharePoint の URL とフォルダパスを確認する
GetFolderByServerRelativeUrl メソッドは、サイトのルート相対 URL を指定します。例えば、
%2Fsites%2FYourSite%2FYourFolder のような形式です。
API エンドポイントを構築する
/_api/web/GetFolderByServerRelativeUrl('/<サーバー相対URL>')/Files
という形式でエンドポイントを作成します。
Function getFilePath(ByVal fpath As String) As String
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "Excel", "*.xlsx"
.FilterIndex = 1
.InitialFileName = fpath & "\"
.AllowMultiSelect = False
.Title = "Select file"
If .Show = True Then
Dim PathName As Variant
Dim MyPrompt As String
For Each PathName In .SelectedItems
MyPrompt = MyPrompt & vbCrLf & CStr(PathName)
MyPrompt = CStr(PathName)
Next
End If
End With
getFilePath = MyPrompt
End Function
Function fileNameCheck(ByVal fName As String, ByVal kwd As String, ByVal checkType As String) As Boolean
Dim nameParts() As String
Dim fileType As String
nameParts = Split(fName, ".")
fileType = nameParts(UBound(nameParts))
If (nameParts(0) Like "*" & kwd & "*") And (fileType = checkType) Then
fileNameCheck = True
Else
fileNameCheck = False
End If
End Function
Function fileOpenCheck(ByVal fpath As String, ByVal kwd As String) As Boolean
Dim checkBook As Workbook
Set checkBook = Workbooks.Open(fpath, UpdateLinks:=0)
With checkBook
Dim ws As Worksheet
Dim target As Worksheet
Dim header As Range
Dim shName As String
Dim thisMMEng As String
Dim flg As Boolean
thisMMEng = UCase(Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mmmm"))
shName = kwd & thisMMEng
flg = False
For Each ws In .Worksheets
If ws.Name = shName Then
flg = True
End If
Next ws
If flg Then
Set target = .Worksheets(shName)
With target
Set header = .Range("B2").CurrentRegion.Rows(1)
End With
If header.Cells.item(1) = "No" And header.Cells.item(header.Columns.Count) = "Link" Then
fileOpenCheck = True
Else
checkBook.Close
fileOpenCheck = False
End If
Else
checkBook.Close
fileOpenCheck = False
End If
End With
End Function
Sub mytest()
Dim getpath As String
getpath = getFilePath(ThisWorkbook.path)
If getpath <> "" Then
Dim getFileName As String
Dim fkwd As String: fkwd = "POC_"
Dim ftype As String: ftype = "xlsx"
getFileName = Dir(getpath)
If fileNameCheck(getFileName, fkwd, ftype) Then
If fileOpenCheck(getpath, fkwd) Then
MsgBox "OK"
Else
MsgBox "正しいファイルを選択して！"
End If
Else
MsgBox "正しいファイルを選択して！"
End If
End If
End Sub
Function getFilterValue(ByRef ws As Worksheet, ByRef arr As Variant) As Variant
Dim newArr As Variant
Dim targetCol As Long
Dim i As Long
targetCol = arr(0)
With ws
With .ListObjects(1)
If .AutoFilter.FilterMode Then
.AutoFilter.ShowAllData
End If
With .Range
With .CurrentRegion
'splitArr(1)以降が絞り込みの値
For i = 1 To UBound(arr)
If WorksheetFunction.CountIf(.Columns(targetCol), arr(i)) >= 1 Then
If IsArray(newArr) Then
ReDim Preserve newArr(UBound(newArr) + 1)
newArr(UBound(newArr)) = CStr(arr(i))
Else
ReDim newArr(0)
newArr(0) = CStr(arr(i))
End If
End If
Next i
End With
End With
End With
End With
getFilterValue = newArr
End Function
Sub mytest1002()
Dim ws As Worksheet
Dim str(1 To 2) As String
Dim col(1 To 2) As String
Dim splitArr As Variant
Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long
Set ws = Worksheets("ikeikinset")
str(1) = "5,8,9"
str(2) = "7,8,9"
splitArr = Split(str(1), ",")
col(1) = splitArr(0)
arr1 = getFilterValue(ws, splitArr)
splitArr = Split(str(2), ",")
col(2) = splitArr(0)
arr2 = getFilterValue(ws, splitArr)
With ws
With .ListObjects(1)
If .AutoFilter.FilterMode Then
.AutoFilter.ShowAllData
End If
With .Range
With .CurrentRegion
If IsArray(arr1) Then
Select Case UBound(arr1) + 1
Case 1
.AutoFilter col(1), arr1
Case Is >= 2
.AutoFilter col(1), arr1, xlFilterValues
End Select
End If
If IsArray(arr2) Then
Select Case UBound(arr2) + 1
Case 1
.AutoFilter col(2), arr2
Case Is >= 2
.AutoFilter col(2), arr2, xlFilterValues
End Select
End If
End With
End With
End With
End With
Stop
End Sub
Public Sub test503()
Dim i As Long
Dim startDate As Date
Dim endDate As Date
startDate = CDate("2025/10/15")
endDate = CDate("2027/03/10")
Dim sdate As Long
Dim edate As Long
sdate = CLng(Format(startDate, "yyyymm"))
edate = CLng(Format(endDate, "yyyymm"))
Dim monthCounts As Object
Set monthCounts = CreateObject("Scripting.Dictionary")
Dim currentDate As Date
currentDate = startDate
' 期間を1か月単位でループ処理
Do While sdate <= edate
' 年を取得
Dim currentYear As Integer
currentYear = Year(currentDate)
' Dictionaryに年があればカウントを1加算
If monthCounts.Exists(currentYear) Then
monthCounts(currentYear) = monthCounts(currentYear) + 1
' なければ新規登録してカウントを1とする
Else
monthCounts.Add currentYear, 1
End If
' 次の月に進む
' DateAdd関数を使って1か月後の日付を取得
currentDate = DateAdd("m", 1, currentDate)
sdate = CLng(Format(currentDate, "yyyymm"))
Loop
' --- 結果の表示 ---
' Dictionaryの内容をイミディエイトウィンドウに出力
Dim yearKey As Variant
For Each yearKey In monthCounts.Keys
Debug.Print yearKey & "年: " & monthCounts(yearKey) & "か月"
Next yearKey
' --- Dictionaryから配列への格納（必要に応じて） ---
' キー（年）の配列
Dim yearsArray As Variant
yearsArray = monthCounts.Keys
' 値（月数）の配列
Dim countsArray As Variant
countsArray = monthCounts.Items
' 配列の内容をイミディエイトウィンドウに出力
For i = LBound(yearsArray) To UBound(yearsArray)
Debug.Print yearsArray(i) & "年: " & countsArray(i) & "か月 (配列から)"
Next i
End Sub
Sub query_update()
Dim querylist As Variant
Dim query As QueryTable
Dim queryname As Variant
Dim i As Integer
ReDim querylist(ThisWorkbook.Queries.Count - 1)
For i = 1 To ThisWorkbook.Queries.Count
querylist(i - 1) = ThisWorkbook.Queries(i).Name
Next i
For Each queryname In querylist
Set query = Worksheets(queryname).ListObjects(queryname).QueryTable
query.Refresh BackgroundQuery:=False
Do While query.Refreshing
DoEvents
Loop
MsgBox ("クエリ更新完了")
Next
End Sub