12_入荷 カーゴ保存
Private Sub CommandButton1_Click()
コピー
連番
Workbooks("カーゴデータ.xlsm").Save
Range("G2").Activate
MsgBox "取込ました♪"
End Sub
--------------------------
Sub 連番()
Dim i As Integer
i = 1
Do While Cells(i + 1, "B").Value <> ""
Cells(i + 1, "A").Value = i
i = i + 1
Loop
End Sub
---------------------------
Sub コピー()
Dim flag As Boolean
Dim Fdir As String
Dim FPss As String
Dim FileName As String
Dim Opnbook As Workbook
Dim Z As Worksheet
Dim H As Worksheet
'チラついて五月蝿いのを防止
Application.ScreenUpdating = False
Fdir = pathD & "05_入荷システム\"
FPss = Fdir & "JBRCシステム入荷.xlsm"
FileName = FPss
flag = False
'今開いているブックを調べる
For Each Opnbook In Workbooks
If Opnbook.FullName = FileName Then
flag = True
Exit For
End If
Next Opnbook
'目的のブックが開いてなければ開き、名前をセット
If flag = False Then
Set Opnbook = Workbooks.Open(FileName)
End If
'コピー元先のシートをセット
Set Z = Opnbook.Worksheets("カーゴ集計")
Set H = Workbooks("カーゴデータ.xlsm").Worksheets("カーゴ表")
'コピー元をアクティブにする
Opnbook.Activate
'コピペ 今回コピー元セルには計算があると仮定して、値で貼付けとしている
'２箇所コピペすることにしてある
Z.Range("A3:E53").Copy
H.Range("B1").PasteSpecial Paste:=xlValues
Z.Range("C2").Copy
H.Range("H2").PasteSpecial Paste:=xlValues
'コピー元にもよるけど保存するか否かのダイアログがでたりするのでそれは表示させないで閉じる
Application.DisplayAlerts = False
Opnbook.Close
'主たるブックをアクティブにする
Workbooks("カーゴデータ.xlsm").Activate
H.Range("A1").Select
End Sub
11_入荷 Access側
Private Sub コマンド14_Click() '印刷
Dim Path As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from 5_着荷伝票印刷用"""
DoCmd.OpenQuery "Q_着荷伝票印刷"
DoCmd.SetWarnings True
Path = "D:\JBRC検収システム\16_着荷伝票印刷データ" & "\" & Format$(Date, "yyyymmdd") & "着荷伝票印刷用データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "5_着荷伝票印刷用", Path, True, ""
MsgBox "JBRC検収システム\13_入荷済データ\日付+着荷伝票印刷用データ.xlsxに保存しました。"
End Sub
------------------------------------------------------
Private Sub コマンド2_Click()
Application.Quit
End Sub
Private Sub コマンド3_Click() '朝一番
Dim nuwka As Long
nuwka = MsgBox("JBRCWebから運送データと着荷データはダウンロードしましたか？", vbYesNo)
If nuwka = vbYes Then
DoCmd.RunSQL "DELETE * from 1_未入荷エクスポート"""
DoCmd.SetWarnings False
DoCmd.OpenQuery "1_未入荷データ", acNormal, acEdit
MsgBox "JBRCデータ未入荷データ更新終了♪"
Else
MsgBox "処理は中断しました。"
End If
End Sub
--------------------------------------------
Private Sub コマンド0_Click()
Dim objACCESS As Object
Set objACCESS = CreateObject("Access.Application")
'指定ファイルを開く(ここに指定ファイルのフルパスを記述します)
objACCESS.OpenCurrentDatabase "D:\JBRC検収システム\03_入力済データ\12_保管\年間DB.accdb"
objACCESS.Visible = True
objACCESS.UserControl = True
Set objACCESS = Nothing
End Sub
Private Sub コマンド6_Click() '入荷後作成データ
Dim Path As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from 2_入荷済エクスポート"""
DoCmd.OpenQuery "2_入荷済データ"
DoCmd.RunSQL "DELETE * from 3_カーゴエクスポート"""
DoCmd.OpenQuery "3_カーゴデータ"
DoCmd.RunSQL "DELETE * from 4_着荷伝票エクスポート"""
DoCmd.OpenQuery "Q_着荷伝票データ"
DoCmd.SetWarnings True
Path = "D:\JBRC検収システム\03_入力済データ\13_入荷済データ" & "\" & Format$(Date, "yyyymmdd") & "入荷済データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "2_入荷済エクスポート", Path, True, ""
Path = "D:\JBRC検収システム\03_入力済データ\15_検収用データ\入荷済データ" & "\" & "本日入荷済データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "2_入荷済エクスポート", Path, True, ""
MsgBox "入荷済エクスポートされました♪"
Path = "D:\JBRC検収システム\03_入力済データ\14_カーゴデータ" & "\" & Format$(Date, "yyyymmdd") & "カーゴデータ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "3_カーゴエクスポート", Path, True, ""
MsgBox "カーゴデータエクスポートされました♪"
Path = "D:\JBRC検収システム\03_入力済データ\16_着荷伝票印刷データ" & "\" & Format$(Date, "yyyymmdd") & "着荷伝票データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "4_着荷伝票エクスポート", Path, True, ""
MsgBox "着荷伝票エクスポートされました♪"
MsgBox "年間保管用ボタンをクリツクしてください。"
End Sub
10_入荷 宣言パブリック
Public Const pathN = "×××××2\JBRC検収システム\"
Public Const pathD = "D:\JBRC検収システム\"
9_入荷 重複しないリスト作成
Sub 重複なし()
Sheets("未入荷").Select
Range("R3").Select
ActiveSheet.Range("$A$3:$V$5511").AutoFilter Field:=18, Criteria1:="<>"
Range("Q3:R3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
Application.CutCopyMode = False
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
ActiveSheet.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("未入荷").Select
If Worksheets("未入荷").FilterMode Then
Worksheets("未入荷").ShowAllData
MsgBox ("フィルタを解除しました。")
End If
' ActiveSheet.Range("A3").AutoFilter '// 設定 or 解除
End Sub
12_入荷 カーゴ保存
Private Sub CommandButton1_Click()
コピー
連番
Workbooks("カーゴデータ.xlsm").Save
Range("G2").Activate
MsgBox "取込ました♪"
End Sub
--------------------------
Sub 連番()
Dim i As Integer
i = 1
Do While Cells(i + 1, "B").Value <> ""
Cells(i + 1, "A").Value = i
i = i + 1
Loop
End Sub
---------------------------
Sub コピー()
Dim flag As Boolean
Dim Fdir As String
Dim FPss As String
Dim FileName As String
Dim Opnbook As Workbook
Dim Z As Worksheet
Dim H As Worksheet
'チラついて五月蝿いのを防止
Application.ScreenUpdating = False
Fdir = pathD & "05_入荷システム\"
FPss = Fdir & "JBRCシステム入荷.xlsm"
FileName = FPss
flag = False
'今開いているブックを調べる
For Each Opnbook In Workbooks
If Opnbook.FullName = FileName Then
flag = True
Exit For
End If
Next Opnbook
'目的のブックが開いてなければ開き、名前をセット
If flag = False Then
Set Opnbook = Workbooks.Open(FileName)
End If
'コピー元先のシートをセット
Set Z = Opnbook.Worksheets("カーゴ集計")
Set H = Workbooks("カーゴデータ.xlsm").Worksheets("カーゴ表")
'コピー元をアクティブにする
Opnbook.Activate
'コピペ 今回コピー元セルには計算があると仮定して、値で貼付けとしている
'２箇所コピペすることにしてある
Z.Range("A3:E53").Copy
H.Range("B1").PasteSpecial Paste:=xlValues
Z.Range("C2").Copy
H.Range("H2").PasteSpecial Paste:=xlValues
'コピー元にもよるけど保存するか否かのダイアログがでたりするのでそれは表示させないで閉じる
Application.DisplayAlerts = False
Opnbook.Close
'主たるブックをアクティブにする
Workbooks("カーゴデータ.xlsm").Activate
H.Range("A1").Select
End Sub
11_入荷 Access側
Private Sub コマンド14_Click() '印刷
Dim Path As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from 5_着荷伝票印刷用"""
DoCmd.OpenQuery "Q_着荷伝票印刷"
DoCmd.SetWarnings True
Path = "D:\JBRC検収システム\16_着荷伝票印刷データ" & "\" & Format$(Date, "yyyymmdd") & "着荷伝票印刷用データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "5_着荷伝票印刷用", Path, True, ""
MsgBox "JBRC検収システム\13_入荷済データ\日付+着荷伝票印刷用データ.xlsxに保存しました。"
End Sub
------------------------------------------------------
Private Sub コマンド2_Click()
Application.Quit
End Sub
Private Sub コマンド3_Click() '朝一番
Dim nuwka As Long
nuwka = MsgBox("JBRCWebから運送データと着荷データはダウンロードしましたか？", vbYesNo)
If nuwka = vbYes Then
DoCmd.RunSQL "DELETE * from 1_未入荷エクスポート"""
DoCmd.SetWarnings False
DoCmd.OpenQuery "1_未入荷データ", acNormal, acEdit
MsgBox "JBRCデータ未入荷データ更新終了♪"
Else
MsgBox "処理は中断しました。"
End If
End Sub
--------------------------------------------
Private Sub コマンド0_Click()
Dim objACCESS As Object
Set objACCESS = CreateObject("Access.Application")
'指定ファイルを開く(ここに指定ファイルのフルパスを記述します)
objACCESS.OpenCurrentDatabase "D:\JBRC検収システム\03_入力済データ\12_保管\年間DB.accdb"
objACCESS.Visible = True
objACCESS.UserControl = True
Set objACCESS = Nothing
End Sub
Private Sub コマンド6_Click() '入荷後作成データ
Dim Path As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from 2_入荷済エクスポート"""
DoCmd.OpenQuery "2_入荷済データ"
DoCmd.RunSQL "DELETE * from 3_カーゴエクスポート"""
DoCmd.OpenQuery "3_カーゴデータ"
DoCmd.RunSQL "DELETE * from 4_着荷伝票エクスポート"""
DoCmd.OpenQuery "Q_着荷伝票データ"
DoCmd.SetWarnings True
Path = "D:\JBRC検収システム\03_入力済データ\13_入荷済データ" & "\" & Format$(Date, "yyyymmdd") & "入荷済データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "2_入荷済エクスポート", Path, True, ""
Path = "D:\JBRC検収システム\03_入力済データ\15_検収用データ\入荷済データ" & "\" & "本日入荷済データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "2_入荷済エクスポート", Path, True, ""
MsgBox "入荷済エクスポートされました♪"
Path = "D:\JBRC検収システム\03_入力済データ\14_カーゴデータ" & "\" & Format$(Date, "yyyymmdd") & "カーゴデータ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "3_カーゴエクスポート", Path, True, ""
MsgBox "カーゴデータエクスポートされました♪"
Path = "D:\JBRC検収システム\03_入力済データ\16_着荷伝票印刷データ" & "\" & Format$(Date, "yyyymmdd") & "着荷伝票データ.xlsx"
DoCmd.TransferSpreadsheet acExport, 10, "4_着荷伝票エクスポート", Path, True, ""
MsgBox "着荷伝票エクスポートされました♪"
MsgBox "年間保管用ボタンをクリツクしてください。"
End Sub
10_入荷 宣言パブリック
Public Const pathN = "×××××2\JBRC検収システム\"
Public Const pathD = "D:\JBRC検収システム\"
9_入荷 重複しないリスト作成
Sub 重複なし()
Sheets("未入荷").Select
Range("R3").Select
ActiveSheet.Range("$A$3:$V$5511").AutoFilter Field:=18, Criteria1:="<>"
Range("Q3:R3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
Application.CutCopyMode = False
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
ActiveSheet.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("未入荷").Select
If Worksheets("未入荷").FilterMode Then
Worksheets("未入荷").ShowAllData
MsgBox ("フィルタを解除しました。")
End If
' ActiveSheet.Range("A3").AutoFilter '// 設定 or 解除
End Sub