Public Sou, Syo, Sett As Worksheet
Sub 初期値設定()
Set Sou = Worksheets("操作")
Set Syo = Worksheets("処理")
Set Sett = Worksheets("設定")
End Sub
Sub クリア()
Call 初期値設定
Sou.range("G15:H15").ClearContents
Sou.range("G20:H20").ClearContents
Sou.range("G24:H24").ClearContents
Sou.range("E20").ClearContents
Sou.range("E24").ClearContents
Sou.range("E28").ClearContents
Syo.range("A:E").ClearContents
Sou.range("G10").Font.Name = "Wingdings"
Sou.range("G10").Font.Color = RGB(112, 173, 71)
Sou.range("G10").Value = ChrW(&HFC)
Sou.range("H10").Value = "クリア完了"
End Sub
Sub 読取()
Call 初期値設定
Dim ExcelApp As New Application
Dim wbLoadFile As Workbook
Dim stLoadSheet As Worksheet
Dim adLoadFile As String
Dim LastRow As Long
Dim rc1 As Integer
Dim DicName As Variant
Dim ii As Long
Dim GetName As String
Dim ListName As String
'If Dir(Sett.Range("D3").Value, vbDirectory) = "" Then
'MsgBox "フォルダがありません"
'End If
Application.ScreenUpdating = False
adLoadFile = "C:\Users\kengo\OneDrive\ドキュメント\仕事\改善\19_外注システム\01_VBA\読み取りフォルダ\データ.xlsx"
LastRow = 10
'GoTo Label1
'■ファイル選択
Do While rc1 <> vbOK
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "ファイル選択ダイアログサンプル"
.InitialFileName = Sett.range("D3").Value
.Filters.Add "Excelブック", "*.xlsx*"
.AllowMultiSelect = False
If .Show = -1 Then
adLoadFile = .SelectedItems(1)
rc1 = MsgBox(adLoadFile & vbCr & vbCr & "を読み込みます。よろしいですか？", vbOKCancel)
Else
Exit Sub
End If
End With
Loop
Label1:
'■初期化
Call クリア
'■コピー
'エクセルを不可視で開く
ExcelApp.Visible = False 'エクセル可視/不可視設定
ExcelApp.DisplayAlerts = False '警告メッセージをオフ
Set wbLoadFile = ExcelApp.Workbooks.Open(adLoadFile, , True) '読取り専用で開く
Dim blnFileExists As Boolean
Dim objWorksheet As Worksheet
blnFileExists = False
'全てのシートをループする。
For Each objWorksheet In wbLoadFile.Worksheets
If objWorksheet.Name = "残注データ" Then
blnFileExists = True
Exit For
End If
Next
If blnFileExists = False Then
ExcelApp.DisplayAlerts = True '警告メッセージをオン
ExcelApp.Quit 'Excel終了
Set ExcelApp = Nothing
MsgBox "シート「残注データ」が存在しません。"
Exit Sub
End If
'Set wbLoadFile = Workbooks.Open(adLoadFile, ReadOnly:=True)
Set stLoadSheet = wbLoadFile.Sheets("残注データ")
LastRow = stLoadSheet.range("A1").End(xlDown).Row
Sou.range("G10").Font.Name = "Meiryo UI"
Sou.range("G10").Font.Color = RGB(255, 189, 25)
Sou.range("G10").Value = "！"
Sou.range("H10").Value = "データ取込中です"
Syo.range(Syo.range("A1"), Syo.Cells(LastRow, "E")).Value = stLoadSheet.range(stLoadSheet.range("A1"), stLoadSheet.Cells(LastRow, "E")).Value
ExcelApp.DisplayAlerts = True '警告メッセージをオン
ExcelApp.Quit 'Excel終了
Set ExcelApp = Nothing
label2:
ThisWorkbook.Activate
'■要求課リスト
'連想配列
Set DicName = CreateObject("Scripting.Dictionary")
ListName = ","
'2行~最終行まで、重複しない「商品名」のリストを取得
For ii = 2 To LastRow
'値を変数へ
GetName = Syo.Cells(ii, 4).Value & ","
'重複しないリストを連想配列へ
If Not DicName.Exists(GetName) Then
DicName.Add GetName, GetName
ListName = ListName & GetName
End If
Next ii
'ドロップダウンリストを作成
With Sou.range("E20").Validation
.Delete
.Add _
Type:=xlValidateList, _
Formula1:=ListName
End With
Set DicName = Nothing
'■指定日付リスト
'連想配列
Set DicName = CreateObject("Scripting.Dictionary")
ListName = ","
'2行~最終行まで、重複しない「商品名」のリストを取得
For ii = 2 To LastRow
'値を変数へ
GetName = Syo.Cells(ii, 5).Value & ","
'重複しないリストを連想配列へ
If Not DicName.Exists(GetName) Then
DicName.Add GetName, GetName
ListName = ListName & GetName
End If
Next ii
'ドロップダウンリストを作成
With Sou.range("E24").Validation
.Delete
.Add _
Type:=xlValidateList, _
Formula1:=ListName
End With
Set DicName = Nothing
'■表示替え
Sou.range("G15").Font.Name = "Wingdings"
Sou.range("G15").Font.Color = RGB(112, 173, 71)
Sou.range("G15").Value = ChrW(&HFC)
Sou.range("H15").Value = "読込完了：" & adLoadFile
ThisWorkbook.Activate
Sou.range("E20").Select
End Sub
Sub セル変更時処理(CngCell As String)
Call 初期値設定
If CngCell = "$E$20" Then
If Sou.range("E20").Value <> Sett.range("D7").Value And Sou.range("E20").Value <> "" Then
Sou.range("G20").Font.Name = "Meiryo UI"
Sou.range("G20").Font.Color = RGB(200, 0, 0)
Sou.range("G20").Value = "×"
Sou.range("H20").Value = "設定値と異なっています"
ElseIf Sou.range("E20").Value <> Sett.range("D7").Value And Sou.range("E20").Value = "" Then
Sou.range("G20").Font.Name = "Wingdings"
Sou.range("G20").Font.Color = RGB(112, 173, 71)
Sou.range("G20").ClearContents
Sou.range("H20").ClearContents
ElseIf Sou.range("E20").Value = Sett.range("D7").Value Then
Sou.range("G20").Font.Name = "Wingdings"
Sou.range("G20").Font.Color = RGB(112, 173, 71)
Sou.range("G20").Value = ChrW(&HFC)
Sou.range("H20").Value = "OK"
End If
End If
If CngCell = "$E$24" Then
If Month(Sou.range("E24").Value) = Month(Now) And Sou.range("E24").Value <> "" Then
Sou.range("G24").Font.Name = "Wingdings"
Sou.range("G24").Font.Color = RGB(112, 173, 71)
Sou.range("G24").Value = ChrW(&HFC)
Sou.range("H24").Value = "OK"
ElseIf Month(Sou.range("E24").Value) <> Month(Now) And Sou.range("E24").Value <> "" Then
Sou.range("G24").Font.Name = "Meiryo UI"
Sou.range("G24").Font.Color = RGB(255, 189, 25)
Sou.range("G24").Value = "！"
Sou.range("H24").Value = "日付が今月ではありません"
ElseIf Sou.range("E24").Value = "" Then
Sou.range("G24").Font.Name = "Wingdings"
Sou.range("G24").Font.Color = RGB(112, 173, 71)
Sou.range("G24").ClearContents
Sou.range("H24").ClearContents
End If
End If
If CngCell = "$E$28" Then
If IsDate(Sou.range("E28").Value) = True Then
Sou.range("L28").Value = WeekdayName(Weekday(Sou.range("E28").Value))
If Weekday(Sou.range("E28").Value) = 7 Or Weekday(Sou.range("E28").Value) = 1 Then
Sou.range("G28").Font.Name = "Meiryo UI"
Sou.range("G28").Font.Color = RGB(255, 189, 25)
Sou.range("G28").Value = "！"
Sou.range("H28").Value = "入力した日付は土日です"
ElseIf Weekday(Sou.range("E28").Value) <> 7 And Weekday(Sou.range("E28").Value) <> 1 Then
Sou.range("G28").Font.Name = "Wingdings"
Sou.range("G28").Font.Color = RGB(112, 173, 71)
Sou.range("G28").Value = ChrW(&HFC)
Sou.range("H28").Value = "OK"
End If
ElseIf Sou.range("E28").Value = "" Then
Sou.range("G28").Font.Name = "Wingdings"
Sou.range("G28").Font.Color = RGB(112, 173, 71)
Sou.range("G28").ClearContents
Sou.range("H28").ClearContents
End If
End If
End Sub
Sub test()
'wbLoadFile.Activate
Worksheets("残注データ").Select
'Range(Range("A1"), Cells(LastRow, 5)).Copy
ThisWorkbook.Activate
Syo.Select
'Range(Range("A1"), Cells(LastRow, 5)).PasteSpecial 'xlPasteValues
With Wb.Worksheets("Sheet1")
Worksheets("Sheet1").[A1:B10].Value = .[A1:B10].Value
End With
Dim ExcelApp As New Application
Dim Wb As Workbook
Dim ReadFolderFullPath As String
'開くExcelファイルを指定
ReadFolderFullPath = ThisWorkbook.Path & "\" & "Book1.xlsx"
'エクセルを不可視で開く
ExcelApp.Visible = False 'エクセル可視/不可視設定
ExcelApp.DisplayAlerts = False '警告メッセージをオフ
Set Wb = ExcelApp.Workbooks.Open(ReadFolderFullPath, , True) '読取り専用で開く
'処理例
'別ブックのセルの値を取得
Debug.Print Wb.Worksheets("Sheet1").[A1].Value
ExcelApp.DisplayAlerts = True '警告メッセージをオン
ExcelApp.Quit 'Excel終了
Set ExcelApp = Nothing
End Sub