台帳に入力された内容を注文書の雛形に書き込み、指定したブックに新しいシートとして複写する。レジストリにパスを保存することでブックを記憶することができる。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
Sub OrderSheet() 'HKEY_CURRENT_USER\Software\VB and VBA Program Setting On Error GoTo exception If (Not ActiveWorkbook Is ThisWorkbook) Then MsgBox msg("仕入台帳で起動してください") Exit Sub End If If ThisWorkbook.ReadOnly = True Then If MsgBox("仕入台帳が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub End If tRow = Selection(1).Row bRow = Selection(Selection.Count).Row If (bRow - tRow) + 1 > 12 Then If MsgBox("選択範囲が12行を超えていますが続けますか？", vbYesNo) = vbNo Then Exit Sub End If orderBookPath = GetSetting("注文書", "パス", Application.UserName) If orderBookPath <> "" Then isUseRegPath = MsgBox("記憶した保存先を使用しますか？", vbYesNo) End If If isUseRegPath = vbYes Then Workbooks.Open Filename:=orderBookPath orderBookName = ActiveWorkbook.Name Else ' vbNo, Falseの場合 orderBookPath = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx;*.xlsm") If orderBookPath = False Then Exit Sub SaveSetting "注文書", "パス", Application.UserName, orderBookPath Workbooks.Open Filename:=orderBookPath orderBookName = ActiveWorkbook.Name End If If Workbooks(orderBookName).ReadOnly = True Then If MsgBox("注文書の保存先が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub End If Set thissheet = ThisWorkbook.ActiveSheet If StrConv(thissheet.Range("E" & tRow & "").Text, vbNarrow) Like "*ﾗｷﾞﾝｸﾞ*" Then If MsgBox("ラギング注文書を使用しますか？", vbYesNo) = vbYes Then ThisWorkbook.Sheets("ラギング注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) Else ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) End If Else ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) End If Set targetSheet = Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) '注文書の複写後に代入 targetSheet.Range("G9").Value = Application.UserName targetSheet.Range("A4").Value = thissheet.Range("C" & tRow & "").Text & " 御中" targetSheet.Range("G15").Value = Format(thissheet.Range("D" & tRow & "").Text, "yymmdd") If thissheet.Range("D" & tRow & "").Text = "" Then targetSheet.Range("G15").Value = Format(Now, "yymmdd") End If targetRow = 18 For r = tRow To bRow targetSheet.Range("A" & targetRow & "").Value = thissheet.Range("E" & r & "").Value & " " & thissheet.Range("F" & r & "").Value & " " & thissheet.Range("G" & r & "").Value targetSheet.Range("B" & targetRow & "").Value = thissheet.Range("M" & r & "").Value targetSheet.Range("C" & targetRow & "").Value = thissheet.Range("K" & r & "").Value targetSheet.Range("D" & targetRow & "").Value = thissheet.Range("L" & r & "").Value If thissheet.Range("H" & r & "").Value <> "" Then targetSheet.Range("F" & targetRow & "").Value = thissheet.Range("H" & r & "").Value & "へ納品" End If targetSheet.Range("G" & targetRow & "").Value = thissheet.Range("I" & r & "").Value targetSheet.Range("H" & targetRow & "").Value = thissheet.Range("J" & r & "").Value targetRow = targetRow + 1 Next r If MsgBox("仕入台帳を保存しますか？", vbYesNo) = vbYes Then ThisWorkbook.Save End If If MsgBox("注文書を保存しますか？", vbYesNo) = vbYes Then Workbooks(orderBookName).Save End If Exit Sub exception: MsgBox Err.Description End Sub |