お返事が明日になります。 こちらの質問の追加です、協力いただきたいです。。
お返事が明日になります。 こちらの質問の追加です、協力いただきたいです。。 (https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13234888813?__ysp=77yW6KGM55uu77ya6aCF55uu6KGM44CB77yX6KGM55uu772e77ya44OH44O844K%2F5YWl44Gj44Gm44GE44KLIO%2B8iOihjOaVsOOBruaMh%2BWumuOBr%2BOBquOBl%2BOAgUTliJfjg4fjg7zjgr%2FjgpLln7rmupbjgavooYzmlbDjgpLjgZfjgabjgYTjgZfjgZ%2FjgYTvvIk%3D) 途中まで修正をしたのですが上手くいかず、助けていただきたいです。 ※やりたいこと※ ①ブックを保存するとき、既に同じ名前のファイルがあったら連番で保存するようにしたい。（書いてみたのですがEnd ifの位置が分からなくなってしまい、、Endifエラーがでています） ②依頼書にデータを取り込む際にH列のコードが変わるタイミングでの連番をN列につけたい（添付写真イメージ） Do idate = InputBox("依頼書を作成する日付を選んでください" & vbCrLf & "入力例：20201125") If StrPtr(idate) = 0 Then Exit Sub ' キャンセル時に終了 idate = Left(idate, 4) & "/" & Mid(idate, 5, 2) & "/" & Right(idate, 2) If IsDate(idate) Then Exit Do Loop sdate = DateValue(idate) '日付へ変換 Application.ScreenUpdating = False Application.DisplayAlerts = False Set sh = Worksheets("取リ込み") Set sh1 = Worksheets("依頼書") 'コピーする列を指定 c1 = Array(4, 5, 7, 8, 9, 10, 12) c2 = Array(11, 8, 12, 1, 2, 10, 9) With sh For i = 7 To .Cells(Rows.Count, 4).End(xlUp).Row If .Cells(i, 4) = sdate Then '1件目の時依頼書シートをコピー If sv = "" Then sh1.Copy Set wb = ActiveWorkbook Set sh1 = ActiveSheet sv = .Cells(i, 8) sh1.Cells(42, 5) = .Cells(i, 19) sh1.Cells(42, 5).NumberFormatLocal = "m月d日" j = 3 End If If .Cells(i, 8) <> sv Then j = j + 1 sv = .Cells(i, 8) End If j = j + 1 For ix = 0 To 11 sh1.Cells(j, cp2(ix)).Value = .Cells(i, cp1(ix)).Value Next ix End If Next i End With Application.ScreenUpdating = True If sv = "" Then MsgBox "入力した日付のデータなし" Else '新ブックを名前をつけて保存（出力日をつける） With ThisWorkbook.Worksheets("データ")
fname = .Range("B14") …B14にはR:共通4 個人テスト が入ってます ChDrive .Range("B13") End With fname = fname & "依頼書" & Format(Now, "yyyymmdd") & ".xlsx" If Dir(fname) <> "" Then Do k = k + 1 If k > 5 Then wb.Close Exit Sub End If fname = fname & "依頼書" & Format(Now, "yyyymmdd") & Format(k, "_00") & ".xlsx" Loop While Dir(fname) <> "" End If End If wb.SaveAs filename:=fname & "依頼書" & Format(Now, "yyyymmdd") & ".xlsx"
Visual Basic | Excel・36閲覧・50
ベストアンサー
>既に同じ名前のファイルがあったら連番で保存するようにしたい。 これ結構面倒ですよ。 ファイル名に日付+時刻まで追加すれば簡単なんですがね。 どうしても連番にしたいなら。 ただし連番は1～9の1桁にしてあります。1日にそれ以上になる可能性があるなら、最大何番までにすればいいかを教えて下さい。 Sub test() Dim wb As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim idate As String Dim sdate As Date Dim sv As Variant Dim no As Integer Dim i As Long, j As Long Dim c1() As Variant, c2() As Variant Dim ix As Integer Dim fname As String Dim fno As Integer Do idate = InputBox("出荷依頼書へ転記する日付を選んでください" & vbCrLf & "入力例：20201125") If StrPtr(idate) = 0 Then Exit Sub ' キャンセル時に終了 idate = Left(idate, 4) & "/" & Mid(idate, 5, 2) & "/" & Right(idate, 2) If IsDate(idate) Then Exit Do Loop sdate = DateValue(idate) Application.ScreenUpdating = False Application.DisplayAlerts = False Set sh1 = Worksheets("取り込み") Set sh2 = Worksheets("依頼書") c1 = Array(4, 5, 7, 8, 9, 10, 12) c2 = Array(11, 8, 12, 1, 2, 10, 9) With sh1 For i = 7 To .Cells(Rows.Count, 4).End(xlUp).Row If .Cells(i, 4) = sdate Then '1件目の時依頼書シートをコピー If sv = "" Then sh2.Copy Set wb = ActiveWorkbook Set sh2 = ActiveSheet sv = .Cells(i, 8) sh2.Cells(33, 5) = .Cells(i, 14) sh2.Cells(33, 5).NumberFormatLocal = "m月d日" no = 1 j = 3 End If 'sh2へ転記 If .Cells(i, 8) <> sv Then j = j + 1 sv = .Cells(i, 8) no = no + 1 End If j = j + 1 For ix = 0 To 6 sh2.Cells(j, c2(ix)).Value = .Cells(i, c1(ix)).Value Next ix sh2.Cells(j, 14).Value = no sh2.Cells(j, 14).Font.ColorIndex = 3 '赤字にしたいなら End If Next i End With If sv = "" Then MsgBox "入力した日付のデータなし" Else '新ブックを名前をつけて保存 fno = 0 fname = Dir(ThisWorkbook.Path & "\出荷依頼書" & Format(sdate, "yyyymmdd") & "*.xlsx", vbNormal) Do Until fname = "" If Mid(fname, InStr(fname, "_") + 1, 1) > fno Then fno = Mid(fname, InStr(fname, "_") + 1, 1) End If fname = Dir() Loop fname = ThisWorkbook.Path & "\出荷依頼書" & Format(sdate, "yyyymmdd") & "_" & fno + 1 & ".xlsx" wb.SaveAs FileName:=fname MsgBox "依頼書作成終了" End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
早速のご回答ありがとうございます！ たしかに日時＋時間のほうが簡単ですね… こちらのが良いかもしれないです 連番は１～９までで大丈夫です。 これからトライしてみます。
質問者からのお礼コメント
前回に続いてご協力いただきありがとうございます！！ 希望の形でできました、とても助かりました。 ファイル名連番は次回より＋保存時間分等で対応するようにします。
お礼日時：2020/12/1 10:25
