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
Public Sub test()
Dim wb As Workbook
Dim sh As Worksheet
Dim filePath As String
Dim i As Long
Dim lastCol As Long
Dim setstring As String
filePath = ThisWorkbook.Path & "\csv\Shop_User.csv"
Set wb = Workbooks.Open(filePath)
With wb.Worksheets(1)
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
wb.Close
End With
ReDim arrTypes(1 To lastCol)
setstring = "Array("
For i = 1 To lastCol
arrTypes(i) = xlTextFormat
Next i
Set sh = Worksheets("sheet1")
sh.Cells.Clear
With sh.QueryTables.Add(Connection:="text;" & filePath, Destination:=sh.Range("A1"))
.TextFileColumnDataTypes = arrTypes
.TextFilePlatform = 65001 'UTF-8
.AdjustColumnWidth = False '列の幅を自動計算しない
.TextFileCommaDelimiter = True 'コンマ区切り
.Refresh BackgroundQuery:=False 'シートに出力
.Delete
End With
sh.Activate
End Sub
〇繋いだemp表内
テーブルに1列追加してID、名前、アドレスを結合 → =CONCATENATE([@EmpID],": ",[@EmpName],"(",C2,")")
〇繋いだLicenseList
特になし
〇FilterData
RequestListと同じテーブル構造(copyでOK)
〇Target
FilterDataとempで内部結合結果表
〇RequestList(申請入力シート)
No → =ROW()-1
RequestDate
LicenseCD → =CONCATENATE("TR",[@No])
EmpSearch → 入力規則(=OFFSET(EmpList!$A$2,0,3,COUNTA(EmpList!C:C)-1,1))
EmpID → =IF([@EmpSearch]<>"",VALUE(LEFT([@EmpSearch],FIND(":",[@EmpSearch])-1)),"")
EmpName → =IF([@EmpID]<>"",VLOOKUP(VALUE(LEFT([@EmpSearch],FIND(":",[@EmpSearch])-1)),EmpList!A:C,2,FALSE),"")
MailAddress → =IF([@EmpID]<>"",VLOOKUP(VALUE(LEFT([@EmpSearch],FIND(":",[@EmpSearch])-1)),EmpList!A:C,3,FALSE),"")
LicenseName → 入力規則(=OFFSET(LicenseList!$A$2,0,1,COUNTA(LicenseList!A:A)-1,1))
SentCount
LastSentDate
Response
Progress
CompletionDate
ExpectedCompletionDate
ComfirmFLG
Link
Public Sub targetCreate()
Dim tWb As Workbook
Dim mWb As Workbook
Dim rSht As Worksheet
Dim tSht As Worksheet
Dim fSht As Worksheet
Dim rRng As Range
Dim tRng As Range
Dim queryName As String
Dim filePath As String
On Error GoTo errLV1
Application.ScreenUpdating = False
Set tWb = ThisWorkbook
With tWb
filePath = .Path
Set rSht = .Worksheets("RequestList")
Set tSht = .Worksheets("Target")
Set fSht = .Worksheets("FilterData")
End With
With fSht
If Not .ListObjects(1).DataBodyRange Is Nothing Then
.ListObjects(1).DataBodyRange.Delete
End If
On Error Resume Next
Set rRng = rSht.ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rRng Is Nothing Then
rRng.Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
Else
MsgBox "Copy Data Not find"
Exit Sub
End If
End With
queryName = "Target"
tWb.Queries(queryName).Refresh
Set mWb = Workbooks.Open(filePath & "\MailaddressList.xlsx")
With mWb
With .Worksheets("MailAddressList")
If Not .ListObjects(1).DataBodyRange Is Nothing Then
.ListObjects(1).DataBodyRange.Delete
End If
tSht.ListObjects(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
End With
.Save
.Close
End With
Application.ScreenUpdating = True
MsgBox "complete"
Exit Sub
errLV1:
MsgBox "error: " & Err.Description
End Sub
Sub MultiLevelSort()
Dim tBook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim visibleRng As Range
Dim rng As Range
Dim dic As Object
Dim list As Variant
Dim i As Long
Dim pjCode As String
Dim key As Variant
Dim row As Long
Dim cnt As Long
Set dic = CreateObject("Scripting.Dictionary")
Set tBook = ThisWorkbook
With tBook
Set ws1 = .Worksheets("APARTMENT")
Set ws2 = .Worksheets("Target")
End With
With ws2
row = .Cells(.Rows.Count, 1).End(xlUp).row
ReDim list(row - 1)
For i = 1 To row
list(i - 1) = .Cells(i, 1).Value
Next i
End With
With ws1
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
pjCode = .Cells(i, 1).Value
If dic.Exists(pjCode) = False Then
dic.Add pjCode, pjCode
End If
Next i
With .ListObjects(1)
For Each key In dic
For i = LBound(list) To UBound(list)
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
With .Range
.AutoFilter 1, key
.AutoFilter 2, list(i)
End With
cnt = -1
Set visibleRng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
For Each rng In visibleRng.Areas
cnt = cnt + rng.EntireRow.Count
Next
If cnt > 0 Then
'配列処理
End If
Next i
Next key
End With
End With
End Sub
Sub test()
Dim tBook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim visibleRng As Range
Dim rng As Range
Dim dic As Object
Dim list As Variant
Dim i As Long
Dim j As Long
Dim check As Long
Dim pjCode As String
Dim key As Variant
Dim row As Long
Dim cnt As Long
Dim amt As Long
Dim item As String
Dim arr As Variant
Dim tmp As Variant
Dim arrtmp As Variant
Set dic = CreateObject("Scripting.Dictionary")
Set tBook = ThisWorkbook
With tBook
Set ws1 = .Worksheets("APARTMENT")
list = .Worksheets("Target").Range("B2").CurrentRegion
End With
check = 0
With ws1
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
pjCode = .Cells(i, 1).Value
item = pjCode & "_" & .Cells(i, 2).Value
If item Like "*水道光熱費" Or item Like "*通信費" Then
item = pjCode & "_水道光熱費"
End If
If Not dic.Exists(item) Then
dic.Add item, .Cells(i, 4).Value
Else
dic(item) = dic(item) + .Cells(i, 4).Value
End If
Next i
j = 1
cnt = dic.Count
ReDim arr(1 To cnt, 1 To 7)
With .ListObjects(1)
For Each key In dic
For i = 2 To UBound(list)
If key Like "*" & list(i, 1) Then
tmp = Split(key, "_")
arr(j, 1) = tmp(0)
arr(j, 2) = tmp(1)
arr(j, 3) = dic(key)
arr(j, 4) = list(i, 1)
arr(j, 5) = list(i, 2)
arr(j, 6) = list(i, 3)
arr(j, 7) = list(i, 4)
j = j + 1
End If
Next i
Next key
For Each key In dic
Debug.Print key & " : " & dic(key)
Next key
ReDim arrtmp(1 To 1, 1 To 7)
For i = 1 To cnt - 1
For j = 1 To cnt - 1
If arr(j, 1) > arr(j + 1, 1) Then
arrtmp(1, 1) = arr(j + 1, 1)
arrtmp(1, 2) = arr(j + 1, 2)
arrtmp(1, 3) = arr(j + 1, 3)
arrtmp(1, 4) = arr(j + 1, 4)
arrtmp(1, 5) = arr(j + 1, 5)
arrtmp(1, 6) = arr(j + 1, 6)
arrtmp(1, 7) = arr(j + 1, 7)
arr(j + 1, 1) = arr(j, 1)
arr(j + 1, 2) = arr(j, 2)
arr(j + 1, 3) = arr(j, 3)
arr(j + 1, 4) = arr(j, 4)
arr(j + 1, 5) = arr(j, 5)
arr(j + 1, 6) = arr(j, 6)
arr(j + 1, 7) = arr(j, 7)
arr(j, 1) = arrtmp(1, 1)
arr(j, 2) = arrtmp(1, 2)
arr(j, 3) = arrtmp(1, 3)
arr(j, 4) = arrtmp(1, 4)
arr(j, 5) = arrtmp(1, 5)
arr(j, 6) = arrtmp(1, 6)
arr(j, 7) = arrtmp(1, 7)
'Debug.Print arr(i, 1) & ":" & arr(i, 2) & ":" & arr(i, 3) & ":" & arr(i, 4) & ":" & arr(i, 5) & ":" & arr(i, 6) & ":" & arr(i, 7)
End If
Next j
Next i
For i = 1 To 15
Debug.Print arr(i, 1) & ":" & arr(i, 2) & ":" & arr(i, 3) & ":" & arr(i, 4) & ":" & arr(i, 5) & ":" & arr(i, 6) & ":" & arr(i, 7)
Next i
End With
End With
End Sub
Sub createListDate(ws As Worksheet)
Dim tbl As ListObject
Dim fRng As Range
Dim dRng As Range
Dim i As Long
Dim key As String
Dim dat As Date
Set tbl = ws.ListObjects(1)
With ws
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
If .Cells(i, "C").Value <> "" Then
dat = .Cells(i, "C").Value
key = .Cells(i, "D").Value
With tbl.Range
.AutoFilter Field:=tbl.ListColumns("キーワード").Index, Criteria1:=key
End With
On Error Resume Next
Set dRng = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not dRng Is Nothing Then
For Each fRng In dRng.Areas
.Cells(fRng.row, 3).Value = dat
Next
End If
End If
Next i
End With
tbl.AutoFilter.ShowAllData
End Sub
Function createKeyDic(ws As Worksheet, list As Variant) As Object
Dim tmpDic As Object
Dim i As Long
Dim j As Long
Dim key As String
Dim yyyymm As String
Dim conf_tekiyoMeisai As String
Set tmpDic = CreateObject("Scripting.Dictionary")
yyyymm = Year(Date) & Month(Date)
With ws
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
For j = 2 To UBound(list)
If .Cells(i, "B").Value = list(j, 1) Then
If .Cells(i, "C").Value <> "" Then
conf_tekiyoMeisai = Replace(list(j, 4), "yyyy/mm/dd", .Cells(i, "C").Value)
Else
conf_tekiyoMeisai = Replace(list(j, 4), "yyyymm", yyyymm)
End If
key = .Cells(i, "A").Value & "_" & list(j, 1) & " _" & list(j, 2) & " _" & list(j, 3) & " _" & conf_tekiyoMeisai
If Not tmpDic.Exists(key) Then
tmpDic.Add key, .Cells(i, "E").Value
Else
tmpDic(key) = tmpDic(key) + .Cells(i, "E").Value
End If
End If
Next j
Next i
End With
Set createKeyDic = tmpDic
End Function
Sub createListArray()
Dim tBook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim keyDic As Object
Dim list As Variant
Dim i As Long
Dim j As Long
Dim r As Long
Dim cnt As Long
Dim amt As Long
Dim key As Variant
Dim item As Variant
Dim arr As Variant
Dim arrtmp As Variant
Set keyDic = CreateObject("Scripting.Dictionary")
Set tBook = ThisWorkbook
With tBook
Set ws1 = .Worksheets("get")
list = .Worksheets("Target").Range("B2").CurrentRegion
End With
Call createListDate(ws1)
Set keyDic = createKeyDic(ws1, list)
cnt = keyDic.Count
ReDim arr(1 To cnt, 1 To 6)
ReDim arrtmp(1 To 1, 1 To 7)
i = 1
For Each key In keyDic
item = Split(key, "_")
amt = keyDic(key)
arr(i, 1) = item(0)
arr(i, 2) = item(1)
arr(i, 3) = item(2)
arr(i, 4) = item(3)
arr(i, 5) = item(4)
arr(i, 6) = amt
i = i + 1
Next key
For i = 1 To cnt - 1
For j = 1 To cnt - 1
If arr(j, 1) > arr(j + 1, 1) Then
For r = 1 To 6
arrtmp(1, r) = arr(j + 1, r)
arr(j + 1, r) = arr(j, r)
arr(j, r) = arrtmp(1, r)
Next r
End If
Next j
Next i
For i = 1 To cnt
Debug.Print arr(i, 1) & " " & arr(i, 2) & " " & arr(i, 3) & " " & arr(i, 4) & " " & arr(i, 5) & " " & arr(i, 6)
Next i
End Sub
Sub cancelDelete(ByRef sht As Worksheet)
Dim listTbl As ListObject
Dim deleteKey As String
Dim r As Long
With sht
Set listTbl = .ListObjects(1)
With .Range("A2").CurrentRegion
For r = 2 To .Rows.Count
'キャンセル日付行から予約ID取得 抽出削除
If .Cells(r, "I").Value <> "" Then
deleteKey = .Cells(r, "G").Value
listTbl.Range.AutoFilter 7, deleteKey
.Offset(1).EntireRow.Delete
End If
Next r
End With
End With
If listTbl.AutoFilter.FilterMode = True Then
listTbl.AutoFilter.ShowAllData
End If
End Sub
Sub tableSort(ByRef sht As Worksheet, ByRef sortList As Range)
Dim listTbl As ListObject
Dim listItem As Range
Dim r As Long
With sht
With .Range("A2").CurrentRegion
For r = 2 To .Rows.Count
For Each listItem In sortList.Rows
If .Cells(r, "D").Value = listItem.Columns(2) Then
.Cells(r, "J").Value = listItem.Columns(1)
End If
Next listItem
Next r
End With
Set listTbl = .ListObjects(1)
With listTbl
If .AutoFilter.FilterMode = True Then
.AutoFilter.ShowAllData
End If
.Sort.SortFields.Clear
.Sort.SortFields.Add _
Key:=.ListColumns("プロジェクトコード").Range, _
SortOn:=xlSortOnValues, _
Order:=xlAscending
.Sort.SortFields.Add _
Key:=.ListColumns("予約IID").Range, _
SortOn:=xlSortOnValues, _
Order:=xlAscending
With .Sort
.Header = xlYes
.Apply
End With
End With
End With
End Sub
Sub main()
Dim details As Worksheet
Dim config As Worksheet
Dim sortList As Range
Dim r As Long
Dim UserID As String
Dim UserName As String
Dim persons As Collection: Set persons = New Collection
With ThisWorkbook
Set details = .Worksheets("details")
Set config = .Worksheets("config")
Set sortList = config.Range("A1").CurrentRegion
End With
Call cancelDelete(details)
Call tableSort(details, sortList)
With details
With .Range("A2").CurrentRegion
For r = 2 To .Rows.Count
UserID = .Cells(r, "A").Value
UserName = .Cells(r, "B").Value
With persons
.Add UserName, UserID
End With
Debug.Print persons.Item(UserID)
Next r
End With
End With
End Sub
Function isFile(ByVal filePath As String) As Boolean
If Dir(filePath) = "" Then
isFile = False
Else
isFile = True
End If
End Function
Function isBookOpened(filePath As String) As Boolean
Dim tempBook As Workbook
Dim fileName As String
fileName = Dir(filePath)
isBookOpened = False
For Each tempBook In Workbooks
If tempBook.Name = fileName Then
isBookOpened = True
Exit For
End If
Next tempBook
End Function
Sub table_copy()
Dim tBook As Workbook
Dim targetBk As Workbook
Dim tSheet As Worksheet
Dim targetSht As Worksheet
Dim path As String
Set tBook = ThisWorkbook
With tBook
path = .path & "\" & "test.xlsx"
End With
If isFile(path) = False Then
MsgBox "ファイルが存在しません"
Exit Sub
End If
If isBookOpened(path) Then
MsgBox "既にファイルが開かれています。ファイルを閉じてから実行してください。"
Exit Sub
End If
Set tSheet = tBook.Worksheets("Sheet2")
With tSheet.ListObjects(1)
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.Delete
End If
End With
Set targetBk = Workbooks.Open(path)
Set targetSht = targetBk.Worksheets("Sheet1")
With tSheet
targetSht.ListObjects(1).DataBodyRange.Copy
.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
targetBk.Close
End Sub
Sub tesata()
Dim tbook As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim tbl As ListObject
Dim list As Variant
Dim i As Integer
Dim Dat As Date
Dim key As String
Dim visibleRng As Range
Dim dic As Object
Dim rRng As Range
Dim r As Range
Dim pj As String
Set dic = CreateObject("Scripting.Dictionary")
Set tbook = ThisWorkbook
With tbook
Set ws1 = .Worksheets("テーブル2")
Set tbl = ws1.ListObjects(1)
End With
With ws1
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
If .Cells(i, "D").Value <> "" Then
Dat = .Cells(i, "D").Value
key = .Cells(i, "F").Value
If Not dic.Exists(key) Then
With tbl.Range
.AutoFilter Field:=tbl.ListColumns("予約番号").Index, Criteria1:=key
On Error Resume Next
Set visibleRng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If Not visibleRng Is Nothing Then
Set visibleRng = .Range("A1").CurrentRegion.Offset(1, 0)
With visibleRng
For Each r In .Resize(.Rows.Count - 1).Columns(6).SpecialCells(xlCellTypeVisible).Rows
ws1.Cells(r.row, "D").Value = Dat
pj = ws1.Cells(r.row, "B").Value
Debug.Print pj
Next r
dic.Add key, key
End With
End If
End If
End If
Next i
End With
End Sub
Sub LoopColumnsForEach()
Dim ws As Worksheet
Dim rng As Range
Dim col As Range
Dim dataCell As Range
Dim dataArray() As Variant ' データを格納する配列
Set ws = ThisWorkbook.Sheets("spiral")
Set rng = ws.Range("A1").CurrentRegion
With rng.Offset(1)
Set rng = .Resize(.Rows.Count - 1)
End With
For Each col In rng.Columns
col.Select
Next col
End Sub
Sub mysub5()
Dim ws As Worksheet
Dim editCol As Object
Dim obj As Variant
Dim colArr As Variant
Dim code As String
Dim i As Long: i = 1
Dim r As Long
Set ws = ThisWorkbook.Worksheets("spiral")
Set editCol = CreateObject("Scripting.Dictionary")
With ws
For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
code = .Cells(r, "B").Value
If editCol.Exists(code) = False Then
editCol.Add code, code
End If
Next r
For Each obj In editCol
If .AutoFilter.FilterMode = True Then .ShowAllData
.Range("B1").AutoFilter Field:=2, Criteria1:=obj
With .Range("A1").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
.Range("A50").PasteSpecial Paste:=xlPasteValues
End With
Next obj
End With
End Sub
Sub MainProcedure()
'-----------------------------------------------------
'ColorIndex
'xlNone : なし
'3 : 赤
'5 : 青
'6 : 黄色
'-----------------------------------------------------
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
Call setData(.Range("A10"), "Hello", xlNone)
Call setData(.Range("B10:D10"), "World", 6)
Call setData(.Cells(11, 1), "Test1", xlNone)
Call setData(.Range(.Cells(12, 2), .Cells(12, 4)), "Test2", xlNone)
End With
End Sub
Sub setData(myRange As Range, inputValue As String, paint As String)
myRange.Value = inputValue
myRange.Interior.ColorIndex = paint
End Sub
Sub mainsub()
Dim mydata As Variant
mydata = Array("Apple", "Banana", "Orange")
Call writeDataToSheet(Range("A20:C20"), mydata)
End Sub
Sub writeDataToSheet(myRange As Range, arr As Variant)
myRange.Value = arr
End Sub
Sub RefreshQueryWithErrorHandling()
Dim qt As QueryTable
Set qt = ThisWorkbook.Worksheets("MTB_ECCUBE_PRICE_RANK_ZBOLT (2)").ListObjects(1).QueryTable
' 1. エラーが発生しても停止しない設定
On Error Resume Next
' 2. クエリを更新 (BackgroundQuery:=False で更新完了を待つ)
qt.Refresh BackgroundQuery:=False
' 3. エラーチェック
If Err.Number <> 0 Then
Dim result As VbMsgBoxResult
result = MsgBox("クエリの更新に失敗しました。続行しますか？" & vbCrLf & _
"エラー: " & Err.Description, _
vbYesNo + vbCritical, "エラー発生")
If result = vbNo Then
' キャンセル（中断）の場合
MsgBox "処理を中止しました。"
Err.Clear
Exit Sub
End If
' 続行（Yes）の場合、そのままエラーを無視して進む
Err.Clear
End If
' 4. エラー処理を通常に戻す
On Error GoTo 0
MsgBox "更新処理が完了しました（エラーがあった場合は無視）。"
End Sub
Function test1(ByRef ws As Worksheet, ByVal name As String) As Boolean
Dim i As Long
With ws.Range("A1").CurrentRegion
For i = 2 To .Rows.Count
If .Cells(i, "E").Value = name Then
If InStr(.Cells(i, "C").Value, "部長") > 0 Then
test1 = True
End If
Exit Function
End If
Next i
End With
test1 = False
End Function
Sub test()
Dim ws As Worksheet
Dim i As Long
Dim flg As Boolean
Dim manager As String
Set ws = ThisWorkbook.Worksheets("シート名")
With ws.Range("A1").CurrentRegion
For i = 2 To .Rows.Count
If .Cells(i, "C").Value <> "部長" Then
manager = .Cells(i, "D").Value
flg = False
Do While flg = False
If test1(ws, manager) Then
Exit Do
Else
manager = "横尾 勤"
End If
Loop
End If
Next i
End With
End Sub
Public Sub test()
Dim ws As Worksheet
Dim dicDept As Object
Dim obj As Variant
Dim cnt As Long
Dim dRng As Range
Set ws = ThisWorkbook.Worksheets("MTB_ECCUBE_PRICE_RANK_ZSET (3)")
Set dicDept = CreateObject("Scripting.Dictionary")
dicDept.Add "生地 斜め", "アンカーセット"
dicDept.Add "生地 寸切", "アンカーセット"
dicDept.Add "生地 寸切のみ", "アンカーセット"
dicDept.Add "ユニクロ 斜め", "アンカーセット"
dicDept.Add "ユニクロ 寸切", "アンカーセット"
dicDept.Add "ユニクロ 寸切のみ", "アンカーセット"
dicDept.Add "ドブ 斜め", "アンカーセット"
dicDept.Add "ドブ 寸切", "アンカーセット"
dicDept.Add "ドブ 寸切のみ", "アンカーセット"
dicDept.Add "ステンレス 斜め", "アンカーセット"
dicDept.Add "ステンレス 寸切", "アンカーセット"
dicDept.Add "ステンレス 寸切のみ", "アンカーセット"
With ws.ListObjects(1)
For Each obj In dicDept
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
.Range.AutoFilter Field:=6, Criteria1:="*" & obj & "*"
cnt = .Range.Columns(6).SpecialCells(xlVisible).Count - 1
If cnt > 0 Then
Debug.Print "aa"
Else
Debug.Print "bb"
End If
' With .Range("A1").CurrentRegion
' .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
' .Range("A50").PasteSpecial Paste:=xlPasteValues
' End With
Next obj
End With
Stop
End Sub
Public Sub fsave(ByRef bk As Workbook, ByVal mypath As String)
Dim Nbook As Workbook
Dim s As Worksheet
Set Nbook = Workbooks.Add
With bk
For Each s In .Worksheets
If s.Name <> "test" Then
.Worksheets(s.Name).Copy After:=Nbook.Worksheets(Nbook.Worksheets.Count)
End If
Next s
End With
With Nbook
.Worksheets(1).Delete
.SaveAs Filename:=mypath & Format(Date, "yymmdd") & "_TEST.xlsx"
End With
End Sub
Public Sub savetest()
Dim mybook As Workbook
Dim mypath As String
Set mybook = ThisWorkbook
mypath = ThisWorkbook.Path & "\save\"
Call fsave(mybook, mypath)
End Sub
Dim ws As Worksheet
Dim i As Long
Dim arrTemp As Variant
ReDim arr(2) As Variant
Dim key As Variant
Dim dicA As Object
Dim items() As String
Dim item As Variant
Set dicA = CreateObject("Scripting.Dictionary")
dicA.Add 61, " 3, 5"
dicA.Add 62, "4,14"
Set ws = Worksheets("testlist")
With ws.ListObjects(1).Range.CurrentRegion
For Each key In dicA
items = Split(dicA(key), ",")
For Each item In items
If WorksheetFunction.CountIf(.Columns(7), item) >= 1 Then Debug.Print "AA"
Next item
Next key
End With
・申請日
手入力
・申請年
=YEAR([@申請日])
・ID列
=YEAR([@申請日]) & "-" & TEXT(COUNTIF($B$2:B2, YEAR([@申請日])),"000")
・emp列
=OFFSET(emp!$D$2,,,COUNTA(emp!$D:$D)-1) 入力規則
・Name列
=MID(D2,FIND("#",D2,1)+1,FIND(":",D2,1)-FIND("#",D2,1)-1)
・MailAddress列
=MID(D2,FIND(":",D2,1)+2,LEN([@Emp]))
〇ニューウィンドウ
Sub testaaa()
With ActiveWorkbook
.NewWindow
Windows.Arrange ArrangeStyle:=xlArrangeStyleCascade
Dim window1 As Window
Set window1 = ActiveWindow
window1.Width = 400
window1.Height = 400
End With
'Sheets("カウント").Select
MsgBox "完了"
End Sub
///シートモジュール///
Option Explicit
Public Enum eFieldsSheet1
eNo = 1
eRequestDate
eTr
eEmp
eName
eMailAddress
eLicense
eStatus
End Enum
Public Persons As Collection
Public MaxId As Long
Public Sub LoadData()
Set Persons = New Collection
With ListObjects(1)
Dim myRow As ListRow
For Each myRow In .ListRows
Dim p As Person: Set p = New Person
p.Initialize myRow.Range
Persons.Add p, p.Tr
Next myRow
MaxId = .ListRows.Count
End With
End Sub
Public Sub ApplyData()
With ListObjects(1)
If .ListRows.Count > 0 Then .DataBodyRange.Delete
Dim p As Person
For Each p In Persons
Dim values As Variant
values = Array(p.No, p.RequestDate, p.Tr, p.Emp, p.Name, p.MailAddress, p.License, p.Status)
.ListRows.Add.Range = values
Next p
MaxId = .ListRows.Count
End With
End Sub
Public Sub UpdatePerson(p As Person)
With Persons(p.No)
.No = p.No
.RequestDate = p.RequestDate
.Tr = p.Tr
.Emp = p.Emp
.Name = p.Name
.MailAddress = p.MailAddress
.License = p.License
.Status = p.Status
End With
Call ApplyData
End Sub
Public Sub AddPerson(p As Person)
Persons.Add p, CStr(p.No)
Call ApplyData
End Sub
///シートモジュール///
///フォーム///
Option Explicit
Private Sub ComboBoxExpirationYesNo_Change()
Select Case ComboBoxExpirationYesNo
Case "無"
Call ExpirationDateGroupClear
Case "有"
Call ExpirationDateGroupEnabled
End Select
End Sub
Private Sub ComboBoxStatus_Change()
Select Case ComboBoxStatus
Case "修了"
Call CompletionGroupEnabled
Call ExpirationDateGroupClear
Call ExCompletionGroupClear
Case "受講前", "受講中"
Call CompletionGroupClear
Call ExpirationDateGroupEnabled
Call ExCompletionGroupEnabled
End Select
End Sub
Private Sub FrameExpectedCompletion_Click()
End Sub
Private Sub UserForm_Initialize()
Call Sheet1.LoadData
Call LoadIdList
End Sub
Private Sub LoadIdList()
With Sheet1.ListObjects(1)
If .ListRows.Count > 1 Then
Dim lists As Variant: lists = .ListColumns(3).DataBodyRange
ComboBoxSelect.List = lists
End If
End With
ComboBoxSelect.AddItem "New"
Call setRequestYear
Call setEmpSearch
Call setLicenseName
Call setStatus
Call setYear
Call setMonth
Call setExpirationYesNo
FrameNewRequest.Enabled = False
FrameExpectedCompletion.Enabled = False
FrameCompletion.Enabled = False
End Sub
Private Sub ComboBoxSelect_Change()
With ComboBoxSelect
If IsValidCode Then
If .Value = "New" Then
Call ClearFields
Else
Call LoadFields(.Value)
End If
End If
End With
End Sub
Private Property Get IsValidCode() As Boolean
IsValidCode = False
With ComboBoxSelect
If (Left(.Value, 2) = "TR" And .Value Like "*##-###*") Or (.Value = "New") Then IsValidCode = True
End With
End Property
Private Sub LoadFields(ByVal myTr As String)
With Sheet1.Persons(myTr)
TextBoxEmpCD.Value = .Emp
TextBoxName.Value = .Name
TextBoxMailAddress.Value = .MailAddress
ComboBoxLicenseName = .License
ComboBoxStatus = .Status
Call NewRequestGroupClear
End With
End Sub
Private Sub ClearFields()
TextBoxNewTrainingCD.Value = ""
TextBoxEmpCD.Value = ""
TextBoxName.Value = ""
TextBoxMailAddress.Value = ""
ComboBoxLicenseName = ""
ComboBoxStatus = ""
FrameNewRequest.Enabled = True
End Sub
Private Sub ComboBoxReqYear_Change()
Dim searchYear As String
Dim tCount As ListObject
Dim foundRng As Range
Dim row As Long
Dim newCount As Long
ComboBoxReqMonth.Value = ""
ComboBoxReqDay.Value = ""
searchYear = ComboBoxReqYear.Value
Set tCount = Worksheets("count").ListObjects(1)
With tCount
Set foundRng = .ListColumns(1).Range.Find(What:=searchYear, LookAt:=xlWhole)
If Not foundRng Is Nothing Then
row = foundRng.row
Else
row = .Range.Rows.Count + 1
.Range(row, 1) = searchYear
.Range(row, 2) = 0
End If
newCount = .Range(row, 2) + 1
TextBoxNewTrainingCD.Value = "TR" & Right(searchYear, 2) & "-" & Format(newCount, "000")
TextBoxNewNo.Value = newCount
End With
End Sub
Private Sub ComboBoxReqMonth_Change()
ComboBoxReqDay = ""
If ComboBoxReqYear <> "" And ComboBoxReqMonth <> "" Then
Call setDays(ComboBoxReqYear, ComboBoxReqMonth, ComboBoxReqDay)
End If
End Sub
Private Sub ComboBoxExCompletionYear_Change()
ComboBoxExCompletionMonth.Value = ""
ComboBoxExCompletionDay.Value = ""
End Sub
Private Sub ComboBoxExCompletionMonth_Change()
ComboBoxExCompletionDay = ""
If ComboBoxExCompletionYear <> "" And ComboBoxExCompletionMonth <> "" Then
Call setDays(ComboBoxExCompletionYear, ComboBoxExCompletionMonth, ComboBoxExCompletionDay)
End If
End Sub
Private Sub ComboBoxCompletionYear_Change()
ComboBoxCompletionMonth.Value = ""
ComboBoxCompletionDay.Value = ""
End Sub
Private Sub ComboBoxCompletionMonth_Change()
ComboBoxCompletionDay = ""
If ComboBoxCompletionYear <> "" And ComboBoxCompletionMonth <> "" Then
Call setDays(ComboBoxCompletionYear, ComboBoxCompletionMonth, ComboBoxCompletionDay)
End If
End Sub
Private Sub ComboBoxExpirationYear_Change()
ComboBoxExpirationMonth.Value = ""
ComboBoxExpirationDay.Value = ""
End Sub
Private Sub ComboBoxExpirationMonth_Change()
ComboBoxExpirationDay = ""
If ComboBoxExpirationYear <> "" And ComboBoxExpirationMonth <> "" Then
Call setDays(ComboBoxExpirationYear, ComboBoxExpirationMonth, ComboBoxExpirationDay)
End If
End Sub
Private Sub CommandButtonUpdate_Click()
If ComboBoxSelect.Value = "New" Then
If ComboBoxReqYear.Value = "" Then
MsgBox "select year"
Exit Sub
End If
End If
End Sub
Private Sub ComboBoxEmpSearch_Change()
Dim empCd As String
Dim empName As String
Dim empMailAddress As String
With ComboBoxEmpSearch
If .Value <> "" Then
TextBoxEmpCD = Left(.Value, InStr(.Value, "#") - 1)
TextBoxName = Mid(.Value, InStr(.Value, "#") + 1, (InStr(.Value, ":") - 2) - (InStr(.Value, "#")))
TextBoxMailAddress = Mid(.Value, InStr(.Value, ":") + 2, Len(.Value) - InStr(.Value, ":") + 1)
End If
End With
End Sub
Private Sub CommandButtonClose_Click()
Unload Me
End Sub
Private Sub setEmpSearch()
Dim rngCol As Range
Set rngCol = Worksheets("employee").ListObjects(1).ListColumns(4).DataBodyRange
ComboBoxEmpSearch.List = rngCol.Value
End Sub
Private Sub setLicenseName()
Dim rngCol As Range
Set rngCol = Worksheets("license").ListObjects(1).ListColumns(2).DataBodyRange
ComboBoxLicenseName.List = rngCol.Value
End Sub
Private Sub setStatus()
ComboBoxStatus.List = Array("受講前", "受講中", "修了")
End Sub
Private Sub setExpirationYesNo()
ComboBoxExpirationYesNo.List = Array("無", "有")
End Sub
Private Sub setRequestYear()
Dim tRequest As ListObject
Dim targetCol As ListColumn
Dim minDate As Date
Dim minYear As Long
Dim arrYears As Variant
Dim i As Long
Dim j As Long
Set tRequest = Worksheets("request").ListObjects(1)
Set targetCol = tRequest.ListColumns(2)
minDate = Application.WorksheetFunction.Min(targetCol.DataBodyRange)
minYear = Year(minDate)
ReDim arrYears((Year(Date) + 1) - minYear)
j = 0
For i = minYear To Year(Date) + 1
arrYears(j) = i
j = j + 1
Next i
ComboBoxReqYear.List = arrYears
End Sub
Private Sub NewRequestGroupClear()
ComboBoxReqYear.Value = ""
ComboBoxReqMonth.Value = ""
ComboBoxReqDay.Value = ""
TextBoxNewTrainingCD.Value = ""
TextBoxNewNo.Value = ""
FrameNewRequest.Enabled = False
End Sub
Private Sub CompletionGroupEnabled()
' ComboBoxCompletionYear.Value = ""
' ComboBoxCompletionMonth.Value = ""
' ComboBoxCompletionDay.Value = ""
FrameCompletion.Enabled = True
End Sub
Private Sub CompletionGroupClear()
ComboBoxCompletionYear.Value = ""
ComboBoxCompletionMonth.Value = ""
ComboBoxCompletionDay.Value = ""
FrameCompletion.Enabled = False
End Sub
Private Sub ExpirationDateGroupEnabled()
' ComboBoxExpirationYesNo.Value = ""
' ComboBoxExpirationYear.Value = ""
' ComboBoxExpirationMonth.Value = ""
' ComboBoxExpirationDay.Value = ""
FrameExpirationDate.Enabled = True
End Sub
Private Sub ExpirationDateGroupClear()
ComboBoxExpirationYesNo.Value = ""
ComboBoxExpirationYear.Value = ""
ComboBoxExpirationMonth.Value = ""
ComboBoxExpirationDay.Value = ""
FrameExpirationDate.Enabled = False
End Sub
Private Sub ExCompletionGroupEnabled()
' ComboBoxExCompletionYear.Value = ""
' ComboBoxExCompletionMonth.Value = ""
' ComboBoxExCompletionDay.Value = ""
FrameExpectedCompletion.Enabled = True
End Sub
Private Sub ExCompletionGroupClear()
ComboBoxExCompletionYear.Value = ""
ComboBoxExCompletionMonth.Value = ""
ComboBoxExCompletionDay.Value = ""
FrameExpectedCompletion.Enabled = False
End Sub
Private Sub setYear()
Dim minYear As Long
Dim arrYears As Variant
Dim i As Long
Dim j As Long
minYear = Year(Date) - 4
ReDim arrYears((Year(Date) + 5) - minYear)
j = 0
For i = minYear To Year(Date) + 5
arrYears(j) = i
j = j + 1
Next i
ComboBoxExCompletionYear.List = arrYears
ComboBoxCompletionYear.List = arrYears
ComboBoxExpirationYear.List = arrYears
End Sub
Private Sub setMonth()
Dim months As Variant
months = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12")
ComboBoxReqMonth.List = months
ComboBoxExCompletionMonth.List = months
ComboBoxCompletionMonth.List = months
ComboBoxExpirationMonth.List = months
End Sub
Private Sub setDays(y As Object, m As Object, d As Object)
Dim InputYear As Long
Dim InputMonth As Long
Dim lastDay As Long
Dim days As Variant
Dim i As Long
InputYear = CLng(y.Value)
InputMonth = CLng(m.Value)
Select Case InputMonth
Case 1, 3, 5, 7, 8, 10, 12
lastDay = 31
Case 2
If Day(DateSerial(InputYear, 3, 0)) = 29 Then
lastDay = 29
Else
lastDay = 28
End If
Case 4, 6, 9, 11
lastDay = 30
End Select
ReDim days(lastDay - 1)
For i = 1 To lastDay
days(i - 1) = i
Next i
d.List = days
End Sub
///フォーム///
///標準モジュール///
Option Explicit
Sub myTest1()
With Sheet1
.LoadData
Dim p As Person: Set p = New Person
With p
.No = 1
.RequestDate = #3/10/2024#
.Tr = "TR24-001"
.Emp = "'08080"
.Name = "横尾 努"
.MailAddress = "menta2000@yahoo.co.jp"
.Status = "受講前"
End With
.UpdatePerson p
' p.No = .MaxId + 1
' .AddPerson p
End With
End Sub
Sub ShowUserForm()
UserForm1.Show vbModeless
End Sub
///標準モジュール///
///クラス///
Option Explicit
Public No As Long
Public RequestDate As Date
Public Tr As String
Public Emp As String
Public Name As String
Public MailAddress As String
Public License As String
Public Status As String
Public Sub Initialize(ByVal myRange As Range)
No = myRange(eNo).Value
RequestDate = myRange(eRequestDate).Value
Tr = myRange(eTr).Value
Emp = myRange(eEmp).Value
Name = myRange(eName).Value
MailAddress = myRange(eMailAddress).Value
License = myRange(eLicense).Value
Status = myRange(eStatus).Value
End Sub
///クラス///
///バリデーションハイライト///
Private Sub CommandButton1_Click()
Dim ctrl As Control
Dim hasError As Boolean
hasError = False
' フォーム上の全コントロールをチェック
For Each ctrl In Me.Controls
' コントロールがテキストボックスの場合のみチェック
If TypeName(ctrl) = "TextBox" Then
If Trim(ctrl.Value) = "" Then
' 空白ならハイライト
ctrl.BackColor = RGB(255, 200, 200)
If Not hasError Then
' 最初のエラー箇所にフォーカスを当てる
ctrl.SetFocus
hasError = True
End If
Else
' 入力済みの場合は背景色を元に戻す
ctrl.BackColor = vbWhite
End If
End If
Next ctrl
If hasError Then
MsgBox "未入力の項目があります。", vbExclamation, "入力エラー"
Exit Sub
End If
' --- 登録処理 ---
MsgBox "登録完了"
End Sub
Private Sub CommandButtonUpdate_Click()
Dim isError As Boolean
isError = False
If ComboBoxReqYear.Value = "" Then
isError = True
End If
If ComboBoxReqMonth.Value = "" Then
isError = True
End If
If ComboBoxReqDay.Value = "" Then
isError = True
End If
If isError Then
Call errCheckDate(ComboBoxReqYear, ComboBoxReqMonth, ComboBoxReqDay)
Else
Call okCheckDate(ComboBoxReqYear, ComboBoxReqMonth, ComboBoxReqDay)
End If
With TextBoxNewTrainingCD
If .Value = "" Then
.BackColor = RGB(255, 200, 200)
Else
.BackColor = RGB(255, 255, 255)
End If
End With
With TextBoxEmpCD
If .Value = "" Then
.BackColor = RGB(255, 200, 200)
Else
.BackColor = RGB(255, 255, 255)
End If
End With
With TextBoxName
If .Value = "" Then
.BackColor = RGB(255, 200, 200)
Else
.BackColor = RGB(255, 255, 255)
End If
End With
With TextBoxMailAddress
If .Value = "" Then
.BackColor = RGB(255, 200, 200)
Else
.BackColor = RGB(255, 255, 255)
End If
End With
If isError Then
Call errCheckDate(ComboBoxReqYear, ComboBoxReqMonth, ComboBoxReqDay)
Else
Call okCheckDate(ComboBoxReqYear, ComboBoxReqMonth, ComboBoxReqDay)
End If
End Sub
Private Function checkDat1() As Boolean
Dim ctrls As Variant
Dim c As Variant
Dim flg As Boolean
flg = False
ctrls = Array( _
ComboBoxReqYear, _
ComboBoxReqMonth, _
ComboBoxReqDay, _
TextBoxNewTrainingCD _
)
For Each c In ctrls
c.BackColor = RGB(255, 255, 255)
If c.Value = "" Then
flg = True
c.BackColor = RGB(255, 200, 200)
End If
Next c
checkDat1 = flg
End Function
Private Function checkDat2() As Boolean
Dim ctrls As Variant
Dim c As Variant
Dim flg As Boolean
flg = False
ctrls = Array( _
TextBoxEmpCD, _
TextBoxName, _
TextBoxMailAddress _
)
For Each c In ctrls
c.BackColor = RGB(255, 255, 255)
If c.Value = "" Then
flg = True
c.BackColor = RGB(255, 200, 200)
End If
Next c
checkDat2 = flg
End Function
Private Function checkDat3() As Boolean
Dim flg As Boolean
flg = False
ComboBoxLicenseName.BackColor = RGB(255, 255, 255)
If ComboBoxLicenseName.Value = "" Then
flg = True
ComboBoxLicenseName.BackColor = RGB(255, 200, 200)
End If
checkDat3 = flg
End Function
Private Function checkDat4() As Boolean
Dim ctrls As Variant
Dim c As Variant
Dim flg As Boolean
Stop
ctrls = Array(ComboBoxStatus)
flg = False
For Each c In ctrls
c.BackColor = RGB(255, 255, 255)
If c.Value = "" Then
c.BackColor = RGB(255, 200, 200)
checkDat4 = True
Exit Function
End If
Next c
ctrls = Array( _
ComboBoxExCompletionYear, _
ComboBoxExCompletionMonth, _
ComboBoxExCompletionDay, _
ComboBoxCompletionYear, _
ComboBoxCompletionMonth, _
ComboBoxCompletionDay, _
ComboBoxExpirationYesNo, _
ComboBoxExpirationYear, _
ComboBoxExpirationMonth, _
ComboBoxExpirationDay _
)
Select Case c.Value
Case "受講前", "受講中"
Debug.Print c.Value
Case "修了"
Debug.Print c.Value
End Select
' ComboBoxStatus.BackColor = RGB(255, 255, 255)
' If ComboBoxStatus.Value = "" Then
' flg = True
' ComboBoxStatus.BackColor = RGB(255, 200, 200)
' checkDat4 = True
' Exit Function
' Else
'
' ctrls = Array( _
ComboBoxStatus, _
TextBoxEmpCD, _
TextBoxName, _
TextBoxMailAddress _
)
'
'
'
'
'
'
' End If
'
'
'
' For Each c In ctrls
' c.BackColor = RGB(255, 255, 255)
' If c.Value = "" Then
' flg = True
' c.BackColor = RGB(255, 200, 200)
' End If
' Next c
' checkDat4 = flg
End Function
Option Explicit
Function isSheet(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = shName Then
isSheet = True
Exit Function
End If
Next
isSheet = False
End Function
Function createPjDictionary(rng As Range) As Object
Dim r As Long
Dim pjCode As String
Set createPjDictionary = CreateObject("Scripting.Dictionary")
With rng
For r = 2 To .Rows.Count
pjCode = .Cells(r, "D").Value
If Not createPjDictionary.Exists(pjCode) Then
createPjDictionary.Add pjCode, pjCode
End If
Next r
End With
End Function
Function createEmpDictionary(rng As Range) As Object
Dim rRow As Range
Dim empCode As String
Dim workVal As Single
Set createEmpDictionary = CreateObject("Scripting.Dictionary")
For Each rRow In rng.Rows
empCode = rRow.Cells(1, 3).Value
workVal = rRow.Cells(1, 5).Value
If Not createEmpDictionary.Exists(empCode) Then
createEmpDictionary.Add empCode, workVal
Else
createEmpDictionary.Item(empCode) = createEmpDictionary.Item(empCode) + workVal
End If
Next rRow
End Function
Public Sub createTable(sh As Worksheet)
Dim tbl As ListObject
Set tbl = sh.ListObjects.Add(xlSrcRange, sh.Range("A1").CurrentRegion, , xlYes)
tbl.HeaderRowRange.Value = Array("No", "WorkDate ", "EmpCode", "ProjectCode", "WorkDay")
End Sub
Public Sub tableSort(sh As Worksheet, sortCol As Long)
With sh.ListObjects(1)
.Range.Sort key1:=.ListColumns(sortCol).Range, order1:=xlAscending, Header:=xlYes
End With
' テーブルでない場合
' Dim row As Long
' Dim col As Long
'
' row = .Cells(.Rows.Count, 1).End(xlUp).row
' col = .Cells(1, .Columns.Count).End(xlToLeft).Column
'
' .Sort.SortFields.Clear
' .Sort.SortFields.Add Key:=.Range(.Cells(1, sortCol), .Cells(1, sortCol)), Order:=xlAscending
' .Sort.SetRange .Range(.Cells(1, 1), .Cells(row, col))
' .Sort.Header = xlNo
' .Sort.Apply
End Sub
Sub test()
Dim tBook As Workbook
Dim pjDic As Object
Dim timeDic As Object
Dim sWork As Worksheet
Dim rWork As Range
Dim empCol As Long
Dim pjCol As Long
Dim obj As Variant
Dim key As Variant
Dim visibleRng As Range
Dim rRow As Range
empCol = 3
pjCol = 4
Set pjDic = CreateObject("Scripting.Dictionary")
Set timeDic = CreateObject("Scripting.Dictionary")
Set tBook = ThisWorkbook
With tBook
If Not isSheet("Work") Then
.Worksheets("Sheet1").Copy After:=.Worksheets(Worksheets.Count)
.Worksheets(Worksheets.Count).Name = "Work"
End If
Set sWork = .Worksheets("Work")
Set rWork = sWork.Range("A1").CurrentRegion
End With
'sort & set pjdic
Call createTable(sWork)
Call tableSort(sWork, pjCol)
Set pjDic = createPjDictionary(rWork)
If pjDic.Count = 0 Then
MsgBox "error1"
Exit Sub
End If
'sort
Call tableSort(sWork, empCol)
With sWork
For Each obj In pjDic
If .AutoFilter.FilterMode = True Then .ShowAllData
.Range("D1").AutoFilter Field:=4, Criteria1:=obj
On Error Resume Next
Set visibleRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not visibleRng Is Nothing Then
Set timeDic = createEmpDictionary(visibleRng)
For Each key In timeDic
Debug.Print obj & " : " & key & " : " & timeDic(key)
Next key
timeDic.RemoveAll
End If
Next obj
End With
Stop
End Sub
Option Explicit
Function isSheet(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = shName Then
isSheet = True
Exit Function
End If
Next
isSheet = False
End Function
Function createDictionaryFilter(rng As Range) As Object
Dim r As Long
Dim pjtCD As String
Dim mgrName As String
Set createDictionaryFilter = CreateObject("Scripting.Dictionary")
With rng
For r = 2 To .Rows.Count
pjtCD = .Cells(r, 4).Value
mgrName = .Cells(r, 6).Value
If Not createDictionaryFilter.Exists(pjtCD) Then
createDictionaryFilter.Add pjtCD, mgrName
End If
Next r
End With
End Function
Function createDictionaryEmp(rng As Range) As Object
Dim r As Long
Dim uniqueCD As String
Set createDictionaryEmp = CreateObject("Scripting.Dictionary")
With rng
For r = 2 To .Rows.Count
uniqueCD = .Cells(r, 3).Value & .Cells(r, 4).Value
If Not createDictionaryEmp.Exists(uniqueCD) Then
createDictionaryEmp.Add uniqueCD, uniqueCD
End If
Next r
End With
End Function
Public Sub tableSort(sh As Worksheet)
Dim row As Long
Dim col As Long
With sh
row = .Cells(.Rows.Count, 1).End(xlUp).row
col = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Sort.SortFields.Clear
.Sort.SortFields.Add key:=.Range(.Cells(1, 7), .Cells(1, 7)), Order:=xlAscending
.Sort.SortFields.Add key:=.Range(.Cells(1, 4), .Cells(1, 4)), Order:=xlAscending
.Sort.SortFields.Add key:=.Range(.Cells(1, 3), .Cells(1, 3)), Order:=xlAscending
.Sort.SetRange .Range(.Cells(1, 1), .Cells(row, col))
.Sort.Header = xlYes
.Sort.Apply
End With
End Sub
Public Sub editPrjManager(sh As Worksheet)
Dim r As Long
With sh.Range("A1").CurrentRegion
For r = 2 To .Rows.Count
If .Cells(r, 1).Value = "X001" Then
.Cells(r, 2).Value = "Soa Kim"
Exit For
End If
Next r
End With
End Sub
Sub test()
Dim tBook As Workbook
Dim dicFilter As Object
Dim dicEmp As Object
Dim dicTemp As Object
Dim sPrj As Worksheet
Dim sWork As Worksheet
Dim rWork As Range
Dim rRow As Range
Dim obj As Variant
Dim key As Variant
Dim total As Long
Dim cell As Range
Dim i As Long
Dim cnt As Long
Dim arrWorkList As Variant
Dim empCD As String
Dim pjtCD As String
Dim workVal As Single
Dim visibleRng As Range
Set tBook = ThisWorkbook
With tBook
Set sPrj = .Worksheets("PRJ")
Call editPrjManager(sPrj)
If isSheet("Work") Then
Application.DisplayAlerts = False
.Worksheets("Work").Delete
Application.DisplayAlerts = True
End If
.Worksheets("Sheet1").Copy After:=.Worksheets(Worksheets.Count)
.Worksheets(Worksheets.Count).Name = "Work"
Set sWork = .Worksheets("Work")
With sWork
.Range("F1").Value = "MgrName"
.Range("G1").Value = "MgrNo"
cnt = .Cells(.Rows.Count, 1).End(xlUp).row
.Range("F2:F" & cnt).Formula = _
"=IFERROR(XLOOKUP(D2,PRJ!A:A,PRJ!B:B,""""),"""")"
.Range("G2:G" & cnt).Formula = _
"=IFERROR(XLOOKUP(F2,emp!C:C,emp!B:B,""""),"""")"
End With
End With
Set dicFilter = CreateObject("Scripting.Dictionary")
Call tableSort(sWork)
Set rWork = sWork.Range("A1").CurrentRegion
Set dicFilter = createDictionaryFilter(rWork)
If dicFilter.Count = 0 Then
MsgBox "error1"
Exit Sub
End If
Set dicTemp = CreateObject("Scripting.Dictionary")
Set dicEmp = CreateObject("Scripting.Dictionary")
Set dicEmp = createDictionaryEmp(rWork)
ReDim arrWorkList(1 To dicEmp.Count, 1 To 5)
i = 1
With sWork
For Each obj In dicFilter
If .AutoFilterMode = False Then .Range("A1").AutoFilter
If .AutoFilter.FilterMode = True Then .ShowAllData
.Range("A1").AutoFilter Field:=4, Criteria1:=obj
On Error Resume Next
Set visibleRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Stop
If Not visibleRng Is Nothing Then
For Each rRow In visibleRng.Rows
empCD = rRow.Cells(1, 3).Value
pjtCD = rRow.Cells(1, 4).Value
workVal = rRow.Cells(1, 5).Value
If Not dicTemp.Exists(empCD) Then
dicTemp.Add empCD, workVal
Else
dicTemp.item(empCD) = dicTemp.item(empCD) + workVal
End If
Next rRow
Stop
For Each key In dicTemp
arrWorkList(i, 1) = dicFilter(obj)
arrWorkList(i, 2) = obj
arrWorkList(i, 3) = key
arrWorkList(i, 4) = dicTemp(key)
arrWorkList(i, 5) = key
i = i + 1
Next key
Stop
dicTemp.RemoveAll
End If
Next obj
End With
Stop
End Sub
Sub Mysub()
Dim p As Person
Dim ws As Worksheet
Dim baseRng As Range
Dim rng As Range
Dim arr As Variant
Dim i As Long
Dim collps As Collection
Set collps = New Collection
'table
'------------------------------------------------------------------
Set ws = ThisWorkbook.Worksheets("名簿")
With ws.ListObjects(1)
For Each rng In .DataBodyRange.Rows
Set p = New Person
p.Id = rng.Cells(1, 1)
p.Name = rng.Cells(1, 2)
p.Gender = rng.Cells(1, 3)
p.Birthday = rng.Cells(1, 4)
p.Active = rng.Cells(1, 5)
collps.Add p, CStr(p.Id)
Next rng
End With
'old table
'------------------------------------------------------------------
' Set ws = ThisWorkbook.Worksheets("Sheet1")
' With ws.Range("A2").CurrentRegion
' Set baseRng = .Resize(.Rows.Count - 1).Offset(1)
' arr = baseRng.Value
' For i = LBound(arr) To UBound(arr)
' Set p = New Person
' p.Id = arr(i, 1)
' p.Name = arr(i, 2)
' p.Gender = arr(i, 3)
' p.Birthday = arr(i, 4)
' p.Active = arr(i, 5)
' collps.Add p, CStr(p.Id)
' Next i
'
' End With
'------------------------------------------------------------------
Debug.Print collps.Item("3").Name
Debug.Print collps.Item("6").Name
Debug.Print collps.Item("7").Name
Debug.Print collps.Item("8").Name
Debug.Print collps.Item("10").Name
Debug.Print collps.Item("13").Name
End Sub