Excel VBA質問箱 IV

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

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


3579 / 13644 ツリー ←次へ | 前へ→

【61320】特定セルを別ブックへコピペして、保存を繰り返したい kako 09/4/25(土) 23:55 質問[未読]
【61321】Re:特定セルを別ブックへコピペして、保存... りん 09/4/26(日) 14:16 回答[未読]
【61327】Re:特定セルを別ブックへコピペして、保存... kako 09/4/26(日) 18:07 お礼[未読]

【61320】特定セルを別ブックへコピペして、保存を...
質問  kako  - 09/4/25(土) 23:55 -

引用なし
パスワード
   ファイルAのI列に「住所」J列に「氏名」が入力されています(同じ行で対になっております)
ファイルBのA1に「住所」、A2に「氏名」を貼り付けます
このとき、A1には「東京都」と頭に付けてから住所を貼り付けます
ファイルBを、貼り付けたセルA1の「東京都」を取った住所の名前で保存します

ファイルA、B、新たに保存されるファイルは同じフォルダにあります
ファイルAの住所と氏名は、6行目から入力されているのですが最終行は決まっておりません
入力されている行の分だけ、上記の条件で繰り返し処理をします

単純なコピペコード等はできたのですが、条件が増えると上手く組むことができません・・

どなたかご教授いただけますでしょうか
よろしくお願い致します

【61321】Re:特定セルを別ブックへコピペして、保...
回答  りん E-MAIL  - 09/4/26(日) 14:16 -

引用なし
パスワード
   kako さん、こんにちわ。

>ファイルAのI列に「住所」J列に「氏名」が入力されています(同じ行で対になっております)
>ファイルBのA1に「住所」、A2に「氏名」を貼り付けます
>このとき、A1には「東京都」と頭に付けてから住所を貼り付けます
>ファイルBを、貼り付けたセルA1の「東京都」を取った住所の名前で保存します
>
>ファイルA、B、新たに保存されるファイルは同じフォルダにあります

Sub test()
  Dim wb(1 To 2) As Workbook
  Dim II As Long, pt As String
  '
  'AもBも開かれているとして。
  With Application
   Set wb(1) = .Workbooks("A.xls")
   Set wb(2) = .Workbooks("B.xls")
   '保存先フォルダ
   pt = wb(2).Path
   If Right(pt, 1) <> .PathSeparator Then pt = pt & .PathSeparator
  End With
  '
  II = 6
  '対象のシートは共にSheet1だとして。
  Do
   With wb(1).Worksheets("Sheet1").Cells(II, "I")
     If .Value = "" Then Exit Do '住所欄がカラだと終了
     '転記して保存
     wb(2).Worksheets("Sheet1").Range("A1").Value = "東京都" & .Value
     wb(2).Worksheets("Sheet1").Range("A2").Value = .Offset(0, 1).Value
     wb(2).SaveAs pt & .Value & ".xls"
   End With
   II = II + 1
  Loop
  '全処理終了時に閉じておく
  wb(2).Close
  '
  Erase wb
End Sub

たとえばこんな感じです。

>単純なコピペコード等はできたのですが、条件が増えると上手く組むことができません・・
他にも条件があるのでしょうか?

【61327】Re:特定セルを別ブックへコピペして、保...
お礼  kako  - 09/4/26(日) 18:07 -

引用なし
パスワード
   りんさん

こんばんは。
希望通りの結果になりました。
ありがとうございます。

他の細かい条件も、上手いこと動作できました。

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