Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


272 / 3841 ページ ←次へ | 前へ→

【76997】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/28(火) 7:21 -

引用なし
パスワード
   ▼Haruka さん:

ご参考までに空白に見えるところが空白なのかどうかを判定するサンプルです。
新規ブックでお試しください。

Sub 空白確認()
  Dim c As Range
  
  Range("A1:A5").NumberFormatLocal = "G/標準"
  
  Range("A1").ClearContents          '本当の空白
  Range("A2").NumberFormatLocal = "@"     '文字列書式
  Range("A2").Value = ""           '長さ0の文字列
  Range("A3").Value = vbTab          '制御文字
  Range("A4").Value = " "          'スペース
  Range("A5").Formula = "=IF(1=1,"""","""")" '式による【空白】に見える値
  
  MsgBox "今から空白チェックをします"
  
  For Each c In Range("A1:A5")
    MsgBox c.Address(False, False) & ":" & IIf(IsEmpty(c), "空白です", "空白ではありません")
  Next
    
  MsgBox "次に補正を試みます"
  
  For Each c In Range("A1:A5")
    c.Value = Replace(Replace(c.Value, " ", ""), " ", "")
    c.Value = WorksheetFunction.Clean(c)
    c.NumberFormatLocal = "G/標準"
    c.Value = c.Value
  Next
  
  For Each c In Range("A1:A5")
    MsgBox c.Address(False, False) & ":" & IIf(IsEmpty(c), "空白です", "空白ではありません")
  Next
  
End Sub
・ツリー全体表示

【76996】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/27(月) 15:52 -

引用なし
パスワード
   ▼Haruka さん:

>1つ質問なのですが、このコードで元データの1つ目の空白セルまでは
>処理しているのですが、次のセルの地域コードに移行しません。

アップした Test でも Test2 でも、「もちろん」いくつ地域があろうと対応します。
それが、Haruka さんの要件ですから。

こちらで動かすとちゃんと反映していますよ。

そちらでうまくいかなかったのは Test のほうですか?
また、データに不整合があった場合、マクロ内でメッセージをだしていますが
そういうものは、なにか出ましたか?

Test も Test2 も ブロックの間は【空白】だと理解しています。
ただし、Test は、A列の【空白】セルをチェックしています。
で、ブロック間の「空白に見えているセル」に【スペース】が入っていたり、
あるいは、数式で "" といったものになっていれば、空白とはみなしません。
(目に見えない制御文字がはいっていても空白とはみなされません)

Test2は、ちょっと異なる把握で、逆に、【空白以外】が1かたまりのブロックだと認識しています。
ですから、間の【空白】が【スペース】あるいは【目に見えない制御文字】なら空白とはみなされず、次の地域があるという認識が
これまたできなくなります。

まず、ブロックの間の【空白】がどうなっているのか、教えてください。
・ツリー全体表示

【76995】Re:【VBA】不特定数データを検索したシー...
質問  Haruka  - 15/4/27(月) 15:04 -

引用なし
パスワード
   ▼β さん:

検証したら上手く行きました!初心者ですのでβさんのコードがとても勉強に
なりました。本当にありがとうございます!

1つ質問なのですが、このコードで元データの1つ目の空白セルまでは
処理しているのですが、次のセルの地域コードに移行しません。
元データの6行目までは行くのですが、7行目に移行しません。
元データの商品コード数は不特定数なのですが、この処理を繰り返すためには
どのようにしたらいいかご教示頂けると本当に助かります。

リクエストばかりしてしまい、本当にすみません!
ご助言頂けると本当に助かります。宜しくお願い致します。
・ツリー全体表示

【76994】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/27(月) 9:43 -

引用なし
パスワード
   ▼Haruka さん:

はい。検証よろしく。

ところで月コード、内容はよくわからないのですが、仮に各地域シートで
1月はここ、2がつはここ、3月はここ といったことが決まっているなら
その月コードの場所を検索しなくても一発でセットできます。
・ツリー全体表示

【76993】Re:【VBA】不特定数データを検索したシー...
発言  Haruka  - 15/4/27(月) 9:23 -

引用なし
パスワード
   ▼β さん:

丁寧な御回答ありがとうございました!
社から質問していたので、御礼が遅くなってしまい失礼致しました。

これから実際のファイルに適用させてみます。
もしまた分からないところがあったらご質問させて頂ければと思います。

取り急ぎ、御礼をさせて頂きます。
本当にありがとうございました!
・ツリー全体表示

【76992】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/25(土) 6:23 -

引用なし
パスワード
   ▼Haruka さん:

すこしわかりにくいかもしれませんが、地域ごとのブロック取得を別方式で。
各行の各項目の扱いも記述方式をかえてみました。

Sub Test2()
  Dim bs As Worksheet
  Dim ws As Worksheet
  Dim Break As Boolean
  Dim dist As Variant
  Dim cnt As Variant
  Dim com As Variant
  Dim qty As Long
  Dim amt As Long
  Dim pl As Long
  Dim col As Variant
  Dim z As Variant
  Dim allAreas As Range
  Dim myArea As Range
  Dim c As Range
  
  Application.ScreenUpdating = False
  
  Set bs = Sheets("元データ")
  cnt = bs.Range("H1").Value   '月コード
  'A列から地域コードごとの領域を分割して一挙取得
  Set allAreas = bs.Range("A2", bs.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
  For Each myArea In allAreas.Areas  '個々の地域コード領域を取り出す
    Break = True          '最初の行は地域データ
    For Each c In myArea      '各データ行
      If Break Then  '地域コード行
        dist = c.Value
        Select Case dist
          Case 1085, 1091, 1103, 1039, 1132
            Set ws = Worksheets("America")
          Case 1230
            Set ws = Worksheets("China")
          Case Else
            MsgBox "(" & dist & ") 該当する代理店がありません"
            Set ws = Nothing
        End Select
        Break = False
        If Not ws Is Nothing Then
          '地域シートの3行目で月コードの存在する列番号を取得
          col = Application.Match(cnt, ws.Range("A1", ws.UsedRange).Rows(3), 0)
          If IsError(col) Then
            MsgBox "(" & cnt & ")月コードが" & ws.Name & "にないのでスキップします"
            Set ws = Nothing
          End If
        End If
      Else
        Break = False
        If Not ws Is Nothing Then      '地域シートが存在する場合のみ対象
          With c.EntireRow
            com = .Range("A1").Value  '商品コード
            qty = .Range("C1").Value  '数量
            amt = .Range("D1").Value  '金額
            pl = .Range("E1").Value   '利益
          End With
          '地域シートの該当商品コードの行を取得
          z = Application.Match(com, ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp)), 0)
          If IsError(z) Then
            MsgBox "(" & com & ")商品コードが" & ws.Name & "にないのでスキップします"
          Else
            With ws.Cells(z, col - 3)
              .Range("D1").Value = .Range("D1").Value + qty
              .Range("E1").Value = .Range("E1").Value + amt
              .Range("F1").Value = .Range("F1").Value + pl
            End With
          End If
        End If
      End If
    Next
  Next
  
End Sub
・ツリー全体表示

【76991】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/24(金) 19:32 -

引用なし
パスワード
   ▼Haruka さん:

ごめんなさい
 
ws.Cells(z, "D").Value = ws.Cells(z, "D").Value + qty
ws.Cells(z, "E").Value = ws.Cells(z, "E").Value + amt
ws.Cells(z, "F").Value = ws.Cells(z, "F").Value + pl

これを

ws.Cells(z, col).Value = ws.Cells(z, col).Value + qty
ws.Cells(z, col + 1).Value = ws.Cells(z, col + 1).Value + amt
ws.Cells(z, col + 2).Value = ws.Cells(z, col + 2).Value + pl

にしてください。
・ツリー全体表示

【76990】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/24(金) 18:00 -

引用なし
パスワード
   ▼Haruka さん:

以下で試してみてください。

Sub Test()
  Dim bs As Worksheet
  Dim ws As Worksheet
  Dim mRow As Long
  Dim i As Long
  Dim Break As Boolean
  Dim dist As Variant
  Dim cnt As Variant
  Dim com As Variant
  Dim qty As Long
  Dim amt As Long
  Dim pl As Long
  Dim col As Variant
  Dim z As Variant
  
  Application.ScreenUpdating = False
  
  Set bs = Sheets("元データ")
  mRow = bs.Range("A" & Rows.Count).End(xlUp).Row   '元データ最終行番号
  Break = True          '最初の行は地域データ
  cnt = bs.Range("H1").Value   '月コード
  
  For i = 2 To mRow
    If Break Then  '地域コード行
      dist = bs.Cells(i, "A").Value
      Select Case dist
        Case 1085, 1091, 1103, 1039, 1132
          Set ws = Worksheets("America")
        Case 1230
          Set ws = Worksheets("China")
        Case Else
          MsgBox "(" & dist & ") 該当する代理店がありません"
          Set ws = Nothing
      End Select
      Break = False
      If Not ws Is Nothing Then
        '地域シートの3行目で月コードの存在する列番号を取得
        col = Application.Match(cnt, ws.Range("A1", ws.UsedRange).Rows(3), 0)
        If IsError(col) Then
          MsgBox "(" & cnt & ")月コードが" & ws.Name & "にないのでスキップします"
          Set ws = Nothing
        End If
      End If
    Else
      If IsEmpty(bs.Cells(i, "A")) Then    '地域データの間の空白行
        Break = True            '次の行は地域データ
      Else                  '通常のデータ行
        Break = False
        If Not ws Is Nothing Then      '地域シートが存在する場合のみ対象
          com = bs.Cells(i, "A").Value  '商品コード
          qty = bs.Cells(i, "C").Value  '数量
          amt = bs.Cells(i, "D").Value  '金額
          pl = bs.Cells(i, "E").Value   '利益
          '地域シートの該当商品コードの行を取得
          z = Application.Match(com, ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp)), 0)
          If IsError(z) Then
            MsgBox "(" & com & ")商品コードが" & ws.Name & "にないのでスキップします"
          Else
            ws.Cells(z, "D").Value = ws.Cells(z, "D").Value + qty
            ws.Cells(z, "E").Value = ws.Cells(z, "E").Value + amt
            ws.Cells(z, "F").Value = ws.Cells(z, "F").Value + pl
          End If
        End If
      End If
    End If
  
  Next i
  
End Sub
・ツリー全体表示

【76989】[無題]
お礼  rinrin  - 15/4/24(金) 17:56 -

引用なし
パスワード
   親切丁寧な解答 ホントにありがとうございました
できちゃいました。。。^^
ホントに助かりました。ありがとうございます
・ツリー全体表示

【76988】Re:【VBA】不特定数データを検索したシー...
発言  Haruka  - 15/4/24(金) 16:23 -

引用なし
パスワード
   ▼β さん:
>▼Haruka さん:
>
>>>3.:"地域シート"A列の商品コードと、"元データ"A列のコードが一致したら"地域シート"に販売数・売上高・粗利を貼り付ける
>
>貼り付けですね?加算じゃなく。
>で、もし、商品が地域シートに記入されていなければ空振りですか?
>それとも最終行に追加ですか?

βさん

ご質問有難うございます!
すみません、貼り付けでなく加算です。1つの地域シートに複数の地域コードが
含まれる場合があるためです。
あと、地域シートに商品が記入されていないというケースは無い前提です、
元データシートの商品分類は、必ず地域シートのどれかに該当するように
なっています。

御覧頂いて本当に有難うございます。ご助言頂けると嬉しいです!
・ツリー全体表示

【76987】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/24(金) 14:07 -

引用なし
パスワード
   ▼Haruka さん:

>>3.:"地域シート"A列の商品コードと、"元データ"A列のコードが一致したら"地域シート"に販売数・売上高・粗利を貼り付ける

貼り付けですね?加算じゃなく。
で、もし、商品が地域シートに記入されていなければ空振りですか?
それとも最終行に追加ですか?
・ツリー全体表示

【76986】Re:【VBA】不特定数データを検索したシー...
発言  β  - 15/4/24(金) 11:48 -

引用なし
パスワード
   ▼Haruka さん:

こんにちは

>知恵袋とこちらのサイトでの質問の併用は禁止事項に該当しますでしょうか?
>もしそうでしたら、知恵袋の方の質問を取り下げます。

いえいえ。独覚 さんがアップされた質問箱のポリシーを読んでいただければわかる通り
マルチポストは禁止はしていないですね。(知恵袋もそうですね)

ただ、「マナー」として、どこそこにも質問しています ということを明示いただくことと
いずれかで解決した場合、もういいやではなく、別途質問している掲示板にも
どこどこで、どういったような内容で解決しましたと 報告をアップして閉じる。
そういったことが望まれますね。

知恵袋のほうは、結構、多くの回答がよせられると聞いていますので閉じるのは
もったいないと思いますよ。
・ツリー全体表示

【76985】Re:【VBA】不特定数データを検索したシー...
回答  Haruka  - 15/4/24(金) 11:27 -

引用なし
パスワード
   ▼独覚 さん:
ご指摘ありがとうございました。初めての投稿で失礼をしてしまい、
本当に申し訳ありませんでした。こちらの質問は現在Yahoo!知恵袋に
投稿しております。1つ御回答をいただいたのですが、現時点では
問題の解決に至っておりません。

知恵袋とこちらのサイトでの質問の併用は禁止事項に該当しますでしょうか?
もしそうでしたら、知恵袋の方の質問を取り下げます。

初心者でご迷惑をお掛けし、本当に申し訳ありません。
仕事の締め切りが迫っており、質問させていただいた次第です。

ご助言頂ければ本当に助かります。
宜しくお願い致します。
・ツリー全体表示

【76984】Re:【VBA】不特定数データを検索したシー...
発言  独覚  - 15/4/24(金) 11:20 -

引用なし
パスワード
   ▼Haruka さん:
こちらの掲示板の基本方針です。

>別のサイト(掲示板)にまったく同じ目的の投稿をすることを、一般に「マルチポスト」といいます。
>当質問箱では、マルチポストは原則認めています。
>つまり、ほかのサイトで質問したことをこのサイトで質問してもかまわないということです。

>しかし、もしマルチポストをするのなら、可能な限り「○○にも同じ質問を出しました」ということを宣言してください。
>そして、仮に他のサイトで解決したのなら、ここにも必ずその顛末を書いてください。
>質問しっぱなし、というのはモラルに反します。「解決したからいいや」というのではありません。

>また、マルチポストを明示的に禁止しているサイトとのマルチポストをしてはいけません。
・ツリー全体表示

【76983】【VBA】不特定数データを検索したシート...
質問  Haruka  - 15/4/24(金) 11:10 -

引用なし
パスワード
   マクロ初心者です。下記の内容についてマクロを組んでみたのですが、どうしても5.で止まってしまい、6.の作業に移行しません。説明が不十分かもしれませんが、アドバイス頂けると助かります。

"元データ"A列2行目に地域コード、3行目以降に不特定数の商品コードが記入されている。
B列は商品名で、CDE列は販売数量・売上高・粗利が記入されており、このパターンが不特定数繰り返される。
"元データ"のA列は、1つの地域データの後に空白セルが1つあり、その後に次の地域コードがある。
元データシート以降に各地域毎のシートがあり、シート名は地域名になっている(以後地域シート)。
*地域シートはいくつかの地域コードを含む場合がある
"地域シート"はA列に商品コード、それ以降の列は7行目から月毎の販売数量・売上高・粗利を記入する。"地域シート"の構成は全て同じ。
その時によって記入したい時期が変わるので、"元データ"H列に記入された対象時期の数値で時期を判別。
H列の対象時期の数値は"地域シート"の3行目に時期毎に記入されている(Ex.10月→10)

<元データシート>
     A列    B列    C列    D列  E列   F列  G列  H列
01行目 記録日  商品名   販売数量 売上高 粗利益 (空白) 時期 102
02行目 1058   ABC USA Inc 
03行目 7001   りんご    2    2500  1000
04行目 7002   みかん    5    5500  3000
05行目 7003   バナナ    4    3500  1500
06行目 (空白セル)
07行目 1003   DEC China
08行目  901   サバ     2    2500  1000
09行目  902   さんま    5    5500  3000

<地域シート>
     A列  B列     C列    D列  E列   F列  G列  H列
01行目 (空白) 販売実績   北米   (空白)  
02行目 (空白) ABC USA Inc
03行目 (空白) (空白)   (空白)   102
04行目 (空白) (空白)   (空白)   9月
05行目 (空白) コード 商品名  
06行目 (空白)             数量    売上金額    粗利額
07行目 7001  E7001  りんご     2   2500  1000
08行目 7002  E7002  みかん     5   5500  3000
09行目 7003  E7003  バナナ     4   3500  1500

<やりたいこと>
1.:"元データ"の地域コードから該当する"地域シート"名を判別
2.:"元データ"H列の対象時期で"地域シート"の記入場所を判別。
3.:"地域シート"A列の商品コードと、"元データ"A列のコードが一致したら"地域シート"に販売数・売上高・粗利を貼り付ける
4.:3.の作業を"元データ"A列のセルが空白になるまで繰り返し
5.:"元データ"の次のデータに移行し、1.から繰り返し
6.:"元データ"のB列が空白になるまで繰り返し

5.で止まる時は元データの5行目のコピー&ペーストまで行い、自動的に
終了してしまいます。終了した時点では、ペーストしたセルがアクティブに
なっており、次の得意先コードに移行していない様子です。5.の時点でのmの値は
6なので、なぜ次の地域コードに移行しないのか分かりません。

Sub データ入力マクロ()

  Dim ws As Worksheet

  i = 2
  m = 2

  Application.ScreenUpdating = False

Step1:
  
  Worksheets("元データ").Select

'  1.地域シートの検索と定義づけ
    
    Select Case Cells(i, 1)
    
      Case 1085, 1091, 1103, 1039, 1132
      Set ws = Worksheets("America")

      Case 1230
      Set ws = Worksheets("China")
    
      Case Else
      MsgBox ("該当する代理店がありません")
    
    End Select

'  2.データを入れる期間の検索

  cnt = Worksheets("元データ").Range("H" & 1).Value

  ws.Select
  
  d = ws.Range("A3:HS3").Find(cnt).Column
  
'  3.商品コードでデータを検索 該当セルに貼り付け

  Do Until Sheets("元データ").Range("A" & m) = ""
 
  Sheets("元データ").Select
  
  For y = 7 To 210
    
    If Worksheets("元データ").Range("A" & m).Value = ws.Range("A" & y).Value Then
 
    Sheets("元データ").Select
    Range("C" & m, "E" & m).Copy
    ws.Select
    Cells(y, d).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, _
    SkipBlanks:=False, Transpose:=False

  End If
 
  Next y
 
'  4.元データの次の行を検索
 
  m = m + 1
 
  Loop
      
'  5.次の地域コードに移行

  If Sheets("元データ").Cells(m, 1) = "" Then
  m = m + 1
  i = m

  End If

'  6.元データのB列が空白セルになるまで繰り返し
  
  c = Range("B1").End(xlDown).Row
  Do While m < c
  
  GoTo Step1

  Loop


End Sub

以上です。
こちらでは初めての質問で、分かり辛いかと思いますがご助言頂ければ
本当に助かります。どうぞ宜しくお願い致します。
・ツリー全体表示

【76982】Re:VBAでシートを作成
発言  マルチネス  - 15/4/24(金) 8:14 -

引用なし
パスワード
   βさんならもうお気づきと思いますが、他の回答者も閲覧する可能性がありますので。

ht tp://www.excel.studio-kazu.jp/kw/20150423181803.html
・ツリー全体表示

【76981】Re:VBAで文字列中に「スペース」を挿入し...
お礼  β  - 15/4/24(金) 0:12 -

引用なし
パスワード
   ▼γ さん:

ありがとうございます!

(?!pattern) 否定先読み。判定には使われ、かつマッチした値には含まれない。
今後も、パット使えるかどうか心もとないのですが、しっかり覚えておきたいと思います。
手元の、分厚い正規表現の書籍、購入はしたものの、ほとんど、飾ってあるだけの存在でしたが
読み返してみますと、この否定先読みも、(?=pattern)の肯定先読みとともにちゃんと記載されていました。

正規表現については、そのうわっつらを眺めているだけのレベルですが、いつかγさんのように
奥深いところまで修得できればと夢見ています。
・ツリー全体表示

【76980】Re:VBAで文字列中に「スペース」を挿入し...
発言  γ  - 15/4/23(木) 21:11 -

引用なし
パスワード
   (半角英数字一文字または全角文字列)でうしろに\sがないもの、
のつもりです。

今回の説例では、所詮、Trimを使うのであれば、
連続したspaceはいくつあっても問題ないのですが、
一応、正規表現でできるところはしてみようかという積もりでした。

ht tps://msdn.microsoft.com/ja-jp/library/cc392020.aspx
にありますように、(?!pattern)は「否定先読み」と呼ばれているようです。

> (?!pattern)
> pattern で指定しない文字列が続く場合に一致と見なされます (否定先読み)。
> 一致した文字列は記憶されず、後で使用することはできません。
> たとえば、"Windows(?=95|98|NT|2000)" は
> "Windows 3.1" の "Windows" には一致しますが、
> "Windows 2000" の "Windows " には一致しません。
> 先読み処理では、読み進まれた文字は処理済みとは見なされません。
> 一致の検出後、次の検索処理は先読みされた文字列の後からではなく、
> 一致文字列のすぐ後から開始されます。
# "Windows (?=95|98|NT|2000)"の間違いだろうと思いますが。

どうもおじゃましました。
・ツリー全体表示

【76979】Re:VBAでシートを作成
発言  β  - 15/4/23(木) 20:23 -

引用なし
パスワード
   ▼rinrin さん:

こんばんは

コードそのものは シートやセルのSelectは、意味がないのでなくしたらいいなぁとか
GoTO はやめようよとか、その他もろもろ、思うところはありますが、それはさておき。


>現状では全く意図していないところに新しく作成したシートが出来ちゃいます。。。。

  ActiveWorkbook.SaveAs _
    FileName:=File購入依頼書 & "xls"
    
SaveAs で指定する際にはファイルのフルパスを使います。
ブック名だけで保存すると、カレントフォルダに保存されます。

ht ps://msdn.microsoft.com/ja-jp/library/office/ff841185.aspx
・ツリー全体表示

【76978】VBAでシートを作成
質問  rinrin  - 15/4/23(木) 18:13 -

引用なし
パスワード
   Excell2010にコマンドボタンを設定し、”Cmd発注”をクリックすると、必要なメインのExcellシートだけをメイン画面の”実績”フォルダに作成したいです。。。

ではありますが、現状では全く意図していないところに
新しく作成したシートが出来ちゃいます。。。。

どう修正すればよいのか。ご指導よろしくお願いいたします。


Sub Cmd発注()
  Dim i As Single
  Dim Iret As Single
  Dim Size As Single
  Dim lReturn As Long
  Dim ActiveFile As String
  Dim SaveFile, SaveFile1, Hinichi As String
  Dim OpenFile_Name As String
  Dim OpenFile_Name_Dir As String
  
'問い合せダイアログの表示をOFFにします
  Application.DisplayAlerts = False

'依頼No.作成
  OpenFile_Name = ActiveWorkbook.Path

  File購入依頼書 = Sheets("治工具").Range("H6").Value
  Range("H6").Select
  Selection.UnMerge
  Range("H6").Select
  Selection.Copy
  Range("P6").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
  Range("P6").Select

  ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-8],""/"","""")"
  File購入依頼書 = ActiveCell.Value
'保存
  Sheets("治工具").Select
  Range("A8").Select
  Sheets("治工具").Copy After:=Sheets(4)
  ActiveSheet.Name = File購入依頼書
  ActiveFile = ActiveSheet.Name

  Sheets(File購入依頼書).Select
  Sheets(File購入依頼書).Copy
  
'フォルダ名がなければ作成する
  OpenFile_Name_Dir = OpenFile_Name & "\実績\"       'Openフォルダ名取得
  
  If Dir(SaveDir, vbDirectory) = "" Then
    MkDir "実績"
    MkDir OpenFile_Name_Dir
  End If

  ActiveWorkbook.SaveAs _
    FileName:=File購入依頼書 & "xls"
    
  Hinichi = File購入依頼書
  Size = Len(File購入依頼書)              'フルパス名長

  SaveFile = OpenFile_Name_Dir & File購入依頼書 & ".xlsx"  '保存ファイル名創生

  Workbooks(1).Activate
    Sheets(File購入依頼書).Select
    Sheets(File購入依頼書).Delete

  Workbooks(2).Activate

  Size = Len(SaveFile)                'フルパス名長
  For i = Size To 1 Step -1
    If Mid(SaveFile, i, 1) = "\" Then
      SaveFile1 = Right(SaveFile, Size - i)    'Openフルパス名取得
      Exit For
    End If
  Next i
  
  Range("A8").Select
Retry:
  Iret = MsgBox("『" & SaveFile & "』 で保存しますが、宜しいですか?" & vbCrLf + vbLf & "フォルダーを変更する場合は『いいえ』を選択して下さい。", vbQuestion + vbYesNo)
  If Iret = vbYes Then
    Exit Sub
    Else

      lReturn = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveFile1, arg2:=18)
'保存画面 document_text、type_num、prot_pwd、backup、write_res_pwd、read_only_rec
      If lReturn = False Then           'CanselならばRetryに戻る
        GoTo Retry
      End If
  End If

  GoTo FIN
CHK:
  If Err.Number = 76 Then    'Pathが存在しない場合にフォルダー作成
      MkDir OpenFile_Name & File購入依頼書
    Else
      MsgBox (Err.Description)
  End If
  Resume Next

'問い合せダイアログの表示をONに戻します
  Application.DisplayAlerts = True
'発注Skip:
FIN:
End Sub
・ツリー全体表示

272 / 3841 ページ ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free