Excel VBA質問箱 IV

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

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


1033 / 13645 ツリー ←次へ | 前へ→

【76699】Excel2010 データインポートの際データがない時にファイルを閉じたい りえ 15/3/1(日) 4:58 質問[未読]
【76700】Re:Excel2010 データインポートの際データ... β 15/3/1(日) 6:16 発言[未読]
【76701】Re:Excel2010 データインポートの際データ... りえ 15/3/1(日) 6:45 発言[未読]
【76702】Re:Excel2010 データインポートの際データ... β 15/3/1(日) 6:49 発言[未読]
【76704】Re:Excel2010 データインポートの際データ... りえ 15/3/1(日) 7:36 発言[未読]
【76705】Re:Excel2010 データインポートの際データ... β 15/3/1(日) 7:40 発言[未読]
【76706】Re:Excel2010 データインポートの際データ... β 15/3/1(日) 7:56 発言[未読]
【76707】Re:Excel2010 データインポートの際データ... [名前なし]りえ 15/3/2(月) 12:34 お礼[未読]
【76703】Re:Excel2010 データインポートの際データ... β 15/3/1(日) 7:11 発言[未読]

【76699】Excel2010 データインポートの際データが...
質問  りえ  - 15/3/1(日) 4:58 -

引用なし
パスワード
   3つのファイルがありA.xlsを起動し、A.xls内のマクロの記述を元に、B.xlsとC.xlsを立ち上げています

データのインポートをC.xlsのシート1と2に行なっております
B. xlsにデータがあれば下記コードで問題無ですが、
データがない場合にC.xlsとB.xlsを閉じれません
データがあっても、なくてもC.xlsとB.xlsを閉じ、
データがありませんと表示させたく思います。
VBAで行なうにはどのようにすれば良いでしょうか?


Sub ボタン1_Click()

Application.ScreenUpdating = False

Workbooks.Open ("C:\東京\B.xls")
Workbooks.Open ("C:\東京\C.xls")

'sheet1

  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim r As Range
  Dim n As Long
  Dim i As Long, j As Long, k As Long
  
  Set ws1 = Workbooks("C.xls").Worksheets("Sheet1")
  Set ws2 = Workbooks("B.xls").Worksheets("Sheet1")
  Set r = ws2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  If r Is Nothing Then Exit Sub
  n = Int((r.Row - 2) / 20)
  If n < 0 Then Exit Sub
  Application.ScreenUpdating = False
  For i = 0 To n
    If i > 0 Then ws1.Range("A1:J33").Copy ws1.Cells(33 * i + 1, 1)
    For j = 1 To 9
      If j = 1 Then k = j Else k = j + 1
      ws1.Cells(33 * i + 12, k).Resize(20).Value = _
          ws2.Cells(20 * i + 2, j).Resize(20).Value
    Next
  Next
  
Dim x As Long
For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
If Range("G" & x).Value = "数" Then
 Range("J" & x).Value = "送"

End If
Next
       
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\C"
Application.DisplayAlerts = True


'sheet2
Dim ws3 As Worksheet, ws4 As Worksheet
Dim r1 As Range
Dim n1 As Long
Dim i1 As Long, j1 As Long, k1 As Long

Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
If r1 Is Nothing Then Exit Sub
n1 = Int((r1.Row - 2) / 20)
If n1 < 0 Then Exit Sub
Application.ScreenUpdating = False
For i1 = 0 To n1
If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
For j1 = 1 To 9
If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
Next
Next

Dim x1 As Long
For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
If Range("G" & x1).Value = "数" Then
 Range("J" & x1).Value = "送"

 End If
 Next
          
Workbooks("C.xls").Close SaveChanges:=True

Workbooks("B.xls").Close SaveChanges:=False

Application.ScreenUpdating = True
MsgBox "終わりました"

End Sub

【76700】Re:Excel2010 データインポートの際デー...
発言  β  - 15/3/1(日) 6:16 -

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

おはようございます

コード案を提示する前に、ご自身で問題提起されている件の他に確認させてください。

・Sheet1側で処理すべきデータがなかった場合、たとえSheet2側で処理するデータがあったとしても
 処理せず終了していますが、これはいいのですか?
・Sheet1側処理が終わった後の保存ブック名、「C」ではなく「C.xls」とファイル拡張子も明記したほうがよろしいかと思います。
 で、この名前は C.xls というより、元々開いた C.xls と同じ名前ということでいいですね?

【76701】Re:Excel2010 データインポートの際デー...
発言  りえ  - 15/3/1(日) 6:45 -

引用なし
パスワード
   β様
回答ありがとうございます

sheet1側で処理すべきデータですが、sheet1には必ずデータがあります
sheet2側には必ずデータがあるわけではありません

また保存ブック名の件ですが、大変失礼しました
拡張子を省いてすみませんでした
C.xlsになります
そして元々開いていたC.xlsと同一の名前です


β さん:
>▼りえ さん:
>
>おはようございます
>
>コード案を提示する前に、ご自身で問題提起されている件の他に確認させてください。
>
>・Sheet1側で処理すべきデータがなかった場合、たとえSheet2側で処理するデータがあったとしても
> 処理せず終了していますが、これはいいのですか?
>・Sheet1側処理が終わった後の保存ブック名、「C」ではなく「C.xls」とファイル拡張子も明記したほうがよろしいかと思います。
> で、この名前は C.xls というより、元々開いた C.xls と同じ名前ということでいいですね?

【76702】Re:Excel2010 データインポートの際デー...
発言  β  - 15/3/1(日) 6:49 -

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

了解です。

想像で書いているところもありますので当方の誤解あれば指摘願います。
また、書いただけで動かしてはいません。不具合あれば指摘願います。

・もとのコードの構成のまま、途中で処理をうちきらずに、続行させることもできますが
 全体の制御が見えにくくなると思いましたので、処理部分をサブプロシジャ
 (実行したかどうかの戻り値付)にして外だしにしました。

・かつ、Sheet1側、Sheet2側ともに、対象シートが異なるだけで、全く同じ処理でしたので
 一本化しました。

・コード中にもコメント入れましたが

  For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
    If Range("G" & x).Value = "数" Then
      Range("J" & x).Value = "送"
    End If
  Next

 ここだけ、それぞれのセルが、どのシートかの指定がありません。
 追加しておいてください。

Sub ボタン1_Click()
  Dim done As Boolean
  Dim bkB As Workbook
  Dim bkC As Workbook
  
  Application.ScreenUpdating = False
  
  Set bkB = Workbooks.Open("C:\東京\B.xls")
  Set bkC = Workbooks.Open("C:\東京\C.xls")
  
  'sheet1
  done = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
  'sheet2
  done = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
  
  bkB.Close SaveChanges:=False

  If done Then
    Application.DisplayAlerts = False
    bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
    Application.DisplayAlerts = True
  End If
  
  bkC.Close SaveChanges:=False
  
  Application.ScreenUpdating = True
  
  If done Then
    MsgBox "終わりました"
  Else
    MsgBox "処理すべきデータがありませんでした"
  End If
  
End Sub

Private Function Proc(sh1 As Worksheet, sh2 As Worksheet) As Boolean

  Dim r As Range
  Dim n As Long
  Dim i As Long, j As Long, k As Long
  Dim x As Long
  
  Set r = sh2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  
  If r Is Nothing Then Exit Function
  
  n = Int((r.Row - 2) / 20)
  If n < 0 Then Exit Function
  
  Proc = True   '★実行された

  For i = 0 To n
    If i > 0 Then sh1.Range("A1:J33").Copy sh1.Cells(33 * i + 1, 1)
    For j = 1 To 9
      If j = 1 Then k = j Else k = j + 1
      sh1.Cells(33 * i + 12, k).Resize(20).Value = _
      sh2.Cells(20 * i + 2, j).Resize(20).Value
    Next
  Next
  
  '★以下の Cellsと2つのRange。どのシートでしょう? ここにも、sh1. なり sh2.なりを付けてください。
  
  For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
    If Range("G" & x).Value = "数" Then
      Range("J" & x).Value = "送"
    End If
  Next

End Function

【76703】Re:Excel2010 データインポートの際デー...
発言  β  - 15/3/1(日) 7:11 -

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

Main処理のみコード差し換えてください。

Sub ボタン1_Click()
  Dim done1 As Boolean
  Dim done2 As Boolean
  Dim bkB As Workbook
  Dim bkC As Workbook
  
  Application.ScreenUpdating = False
  
  Set bkB = Workbooks.Open("C:\東京\B.xls")
  Set bkC = Workbooks.Open("C:\東京\C.xls")
  
  'sheet1
  done1 = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
  'sheet2
  done2 = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
  
  bkB.Close SaveChanges:=False

  If done1 Or done2 Then
    Application.DisplayAlerts = False
    bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
    Application.DisplayAlerts = True
  End If
  
  bkC.Close SaveChanges:=False
  
  Application.ScreenUpdating = True
  
  If done1 Or done2 Then
    MsgBox "終わりました"
  Else
    MsgBox "処理すべきデータがありませんでした"
  End If
  
End Sub

【76704】Re:Excel2010 データインポートの際デー...
発言  りえ  - 15/3/1(日) 7:36 -

引用なし
パスワード
   β様

回答ありがとうございます

私が質問をさせて頂いたコードの構成のままで
お願い出来ませんか?

各シートには罫線で囲われた表があり、
20行毎にデータをインポートしています
各シートのフォーマットを維持したままやりたく思います


お手数ばかりおかけして申し訳ありません

>了解です。
>
>想像で書いているところもありますので当方の誤解あれば指摘願います。
>また、書いただけで動かしてはいません。不具合あれば指摘願います。
>
>・もとのコードの構成のまま、途中で処理をうちきらずに、続行させることもできますが
> 全体の制御が見えにくくなると思いましたので、処理部分をサブプロシジャ
> (実行したかどうかの戻り値付)にして外だしにしました。
>
>・かつ、Sheet1側、Sheet2側ともに、対象シートが異なるだけで、全く同じ処理でしたので
> 一本化しました。
>
>・コード中にもコメント入れましたが
>
>  For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>    If Range("G" & x).Value = "数" Then
>      Range("J" & x).Value = "送"
>    End If
>  Next
>
> ここだけ、それぞれのセルが、どのシートかの指定がありません。
> 追加しておいてください。
>
>Sub ボタン1_Click()
>  Dim done As Boolean
>  Dim bkB As Workbook
>  Dim bkC As Workbook
>  
>  Application.ScreenUpdating = False
>  
>  Set bkB = Workbooks.Open("C:\東京\B.xls")
>  Set bkC = Workbooks.Open("C:\東京\C.xls")
>  
>  'sheet1
>  done = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
>  'sheet2
>  done = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
>  
>  bkB.Close SaveChanges:=False
>
>  If done Then
>    Application.DisplayAlerts = False
>    bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
>    Application.DisplayAlerts = True
>  End If
>  
>  bkC.Close SaveChanges:=False
>  
>  Application.ScreenUpdating = True
>  
>  If done Then
>    MsgBox "終わりました"
>  Else
>    MsgBox "処理すべきデータがありませんでした"
>  End If
>  
>End Sub
>
>Private Function Proc(sh1 As Worksheet, sh2 As Worksheet) As Boolean
>
>  Dim r As Range
>  Dim n As Long
>  Dim i As Long, j As Long, k As Long
>  Dim x As Long
>  
>  Set r = sh2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
>  
>  If r Is Nothing Then Exit Function
>  
>  n = Int((r.Row - 2) / 20)
>  If n < 0 Then Exit Function
>  
>  Proc = True   '★実行された
>
>  For i = 0 To n
>    If i > 0 Then sh1.Range("A1:J33").Copy sh1.Cells(33 * i + 1, 1)
>    For j = 1 To 9
>      If j = 1 Then k = j Else k = j + 1
>      sh1.Cells(33 * i + 12, k).Resize(20).Value = _
>      sh2.Cells(20 * i + 2, j).Resize(20).Value
>    Next
>  Next
>  
>  '★以下の Cellsと2つのRange。どのシートでしょう? ここにも、sh1. なり sh2.なりを付けてください。
>  
>  For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>    If Range("G" & x).Value = "数" Then
>      Range("J" & x).Value = "送"
>    End If
>  Next
>
>End Function

【76705】Re:Excel2010 データインポートの際デー...
発言  β  - 15/3/1(日) 7:40 -

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

>各シートには罫線で囲われた表があり、
>20行毎にデータをインポートしています
>各シートのフォーマットを維持したままやりたく思います

別だしにしていますが、実行内容は元コードと全く同じですけど?
なので、アップしたコードでフォーマットが壊れることはないと思いますが??

>私が質問をさせて頂いたコードの構成のままで
>お願い出来ませんか?

ご希望ということなら、後ほどアップします。

【76706】Re:Excel2010 データインポートの際デー...
発言  β  - 15/3/1(日) 7:56 -

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

ご希望なので。
先にコメントしたところも含めて、コードは、すべて元のままにしてあります。
気になるところも多々ありますが・・・・・・
Sheet1 は必ず処理されるんだということですから、Sheet2 の部分だけを以下。

  'sheet2
  Dim ws3 As Worksheet, ws4 As Worksheet
  Dim r1 As Range
  Dim n1 As Long
  Dim i1 As Long, j1 As Long, k1 As Long
  Dim done As Boolean     '★
  
  Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
  Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
  Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
  
  If Not r1 Is Nothing Then  '★
  
    n1 = Int((r1.Row - 2) / 20)
    
    If n1 >= 0 Then     '★
      
      done = True     '★
      
      Application.ScreenUpdating = False
      For i1 = 0 To n1
        If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
        For j1 = 1 To 9
          If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
          ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
          ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
        Next
      Next
      
      Dim x1 As Long
      For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
        If Range("G" & x1).Value = "数" Then
          Range("J" & x1).Value = "送"
        
        End If
      Next
      
    End If   '★
    
  End If     '★
  
  Workbooks("C.xls").Close SaveChanges:=True
  
  Workbooks("B.xls").Close SaveChanges:=False
  
  Application.ScreenUpdating = True
  
  If done Then
    MsgBox "終わりました"
  Else
    MsgBox "Sheet2に処理すべきデータはありませんでした"
  End If

【76707】Re:Excel2010 データインポートの際デー...
お礼  [名前なし]りえ  - 15/3/2(月) 12:34 -

引用なし
パスワード
   β様

ありがとうございました
▼β さん:
>▼りえ さん:
>
>ご希望なので。
>先にコメントしたところも含めて、コードは、すべて元のままにしてあります。
>気になるところも多々ありますが・・・・・・
>Sheet1 は必ず処理されるんだということですから、Sheet2 の部分だけを以下。
>
>  'sheet2
>  Dim ws3 As Worksheet, ws4 As Worksheet
>  Dim r1 As Range
>  Dim n1 As Long
>  Dim i1 As Long, j1 As Long, k1 As Long
>  Dim done As Boolean     '★
>  
>  Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
>  Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
>  Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
>  
>  If Not r1 Is Nothing Then  '★
>  
>    n1 = Int((r1.Row - 2) / 20)
>    
>    If n1 >= 0 Then     '★
>      
>      done = True     '★
>      
>      Application.ScreenUpdating = False
>      For i1 = 0 To n1
>        If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
>        For j1 = 1 To 9
>          If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
>          ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
>          ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
>        Next
>      Next
>      
>      Dim x1 As Long
>      For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>        If Range("G" & x1).Value = "数" Then
>          Range("J" & x1).Value = "送"
>        
>        End If
>      Next
>      
>    End If   '★
>    
>  End If     '★
>  
>  Workbooks("C.xls").Close SaveChanges:=True
>  
>  Workbooks("B.xls").Close SaveChanges:=False
>  
>  Application.ScreenUpdating = True
>  
>  If done Then
>    MsgBox "終わりました"
>  Else
>    MsgBox "Sheet2に処理すべきデータはありませんでした"
>  End If

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