Excel VBA質問箱 IV

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

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


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

【75538】ループ→転記→ループ→転記 him 14/5/11(日) 23:48 質問[未読]
【75539】Re:ループ→転記→ループ→転記 γ 14/5/12(月) 20:09 発言[未読]
【75545】Re:ループ→転記→ループ→転記 him 14/5/13(火) 21:28 回答[未読]
【75546】Re:ループ→転記→ループ→転記 γ 14/5/13(火) 22:16 発言[未読]
【75550】Re:ループ→転記→ループ→転記 him 14/5/15(木) 2:08 質問[未読]
【75551】Re:ループ→転記→ループ→転記 γ 14/5/15(木) 6:18 発言[未読]
【75553】Re:ループ→転記→ループ→転記 γ 14/5/15(木) 23:09 発言[未読]
【75540】Re:ループ→転記→ループ→転記 こたつねこ 14/5/12(月) 22:41 回答[未読]
【75544】Re:ループ→転記→ループ→転記 him 14/5/13(火) 21:23 お礼[未読]
【75552】Re:ループ→転記→ループ→転記 him 14/5/15(木) 21:47 質問[未読]
【75554】Re:ループ→転記→ループ→転記 こたつねこ 14/5/16(金) 21:37 回答[未読]
【75570】Re:ループ→転記→ループ→転記 him 14/5/18(日) 17:40 お礼[未読]
【75573】Re:ループ→転記→ループ→転記 γ 14/5/18(日) 22:27 発言[未読]

【75538】ループ→転記→ループ→転記
質問  him  - 14/5/11(日) 23:48 -

引用なし
パスワード
   こんばんは。

VBA初心者で困っています。
ご教示お願い致します。

状態(シート3枚)
シート1→計算式が入っておりB4セルの数値が変化によってシート3からVLOOKUPで
飛んできたデータで計算される。
シート2→転記シート(シート1で計算された結果が転記される)
シート3→元データ

やりたいこと
・inputboxでシート3のデータ番号の入力範囲を設定したい(1から100など)
・上記のシート3の1のデータをシート1で計算され、シート2に計算されたデータを転記したい。
(0データがあった場合は転記しない。)
(転記する部分はC30,D30,E30,F30)
そのあとシート2の転記されたデータの下に、続けてシート3のデータ2の計算を転記。その繰り返しをしたいのです。


分かりづらくてすみません。

ご教示よろしくお願い致します。


(下記が途中までです)

Dim x As Integer

x = Application.InputBox(prompt:="先頭の番号を入力してください")
Y = Application.InputBox(prompt:="最終の番号を入力してください")


line:

Worksheets("1").Select
Range("B4").Select

    For i = x To Y

       ActiveCell.FormulaR1C1 = i

【75539】Re:ループ→転記→ループ→転記
発言  γ  - 14/5/12(月) 20:09 -

引用なし
パスワード
   > ・inputboxでシート3のデータ番号の入力範囲を設定したい(1から100など)
> ・上記のシート3の1のデータをシート1で計算され、
>  シート2に計算されたデータを転記したい。
> (0データがあった場合は転記しない。)
> (転記する部分はC30,D30,E30,F30)

(Q1)「シート3のデータ番号の入力範囲」とは何ですか?
  1から100 とした場合は、1行目から100行目ということですか?
  何列目ですか?

(Q2)その100個の値を、順にSheet1のB4セルに入れて、
  その結果の C30,D30,E30,F30 の4つのセルの値を
  Sheet2に転記する作業を100回繰り返すのですね?

(Q3)転記先は、どこのセルから始めるのですか?

【75540】Re:ループ→転記→ループ→転記
回答  こたつねこ  - 14/5/12(月) 22:41 -

引用なし
パスワード
   him さんこんばんは

不明な部分もありますが、こんな感じですかねぇ
適当にコメントを付けておきますので、ご要望の動作でない場合ご自分で修正
してみてください。

Public Sub sample()
 Const C_SHT_NAME_FM As String = "1"  '転記元シート名
 Const C_SHT_NAME_TO As String = "2"  '転記先シート名
 Const C_EVT_ADDR_S1 As String = "B4" 'シート1の参照元データ指定セルアドレス
 Const C_PST_ADDR_01 As String = "C30" 'シート1の転記元アドレス1
 Const C_PST_ADDR_02 As String = "D30" 'シート1の転記元アドレス2
 Const C_PST_ADDR_03 As String = "E30" 'シート1の転記元アドレス3
 Const C_PST_ADDR_04 As String = "F30" 'シート1の転記元アドレス4
 Const C_STR_COL_01 As String = "A"  'シート2の転記先列1
 Const C_STR_COL_02 As String = "B"  'シート2の転記先列2
 Const C_STR_COL_03 As String = "C"  'シート2の転記先列3
 Const C_STR_COL_04 As String = "D"  'シート2の転記先列4
 
 Dim ShtTo As Excel.Worksheet     '転記先シートObject
 Dim ShtFm As Excel.Worksheet     '転記元シートObject
 Dim StartNo As String         '先頭データ指定番号格納
 Dim StopNo As String         '最終データ指定番号格納
 Dim TargetNo As Long         '処理対象データ番号格納
 Dim PostRow As Long          '転記先行番号格納用
 Dim FlgPost As Boolean        '転記判定用フラグ
 Dim Msg As String           'エラーメッセージ格納
 
 '対象データの先頭と最終を取得
 StartNo = Application.InputBox(prompt:="先頭の番号を入力してください")
 StopNo = Application.InputBox(prompt:="最終の番号を入力してください")
  
 If (CheckInput(StartNo, StopNo, Msg) = False) Then
  MsgBox Msg, vbCritical, "エラー"
 Else
  Set ShtTo = ThisWorkbook.Sheets(C_SHT_NAME_TO)
  Set ShtFm = ThisWorkbook.Sheets(C_SHT_NAME_FM)
  
  '入力された先頭番号から最終番号の間繰り返す
  For TargetNo = CLng(StartNo) To CLng(StopNo)
   '転記元シートの参照先指定セルに番号をセット
   ShtFm.Range(C_EVT_ADDR_S1).Value = TargetNo
   
   '転記判定フラグを転記するにセット
   FlgPost = True
   
   '条件:値0がある場合は転記判定フラグを転記しないにセット
   If (ShtFm.Range(C_PST_ADDR_01).Value = 0) Then
    FlgPost = False
   ElseIf (ShtFm.Range(C_PST_ADDR_02).Value = 0) Then
    FlgPost = False
   ElseIf (ShtFm.Range(C_PST_ADDR_03).Value = 0) Then
    FlgPost = False
   ElseIf (ShtFm.Range(C_PST_ADDR_04).Value = 0) Then
    FlgPost = False
   End If
   
   '転記判定フラグが転記するの場合転記
   If (FlgPost) Then
    '転記先行番号取得、データがない場合は1行目
    PostRow = ShtTo.Range(C_STR_COL_01 & ShtTo.Rows.Count).End(xlUp).Offset(1, 0).Row
    ShtTo.Range(C_STR_COL_01 & PostRow).Value = ShtFm.Range(C_PST_ADDR_01).Value
    ShtTo.Range(C_STR_COL_02 & PostRow).Value = ShtFm.Range(C_PST_ADDR_02).Value
    ShtTo.Range(C_STR_COL_03 & PostRow).Value = ShtFm.Range(C_PST_ADDR_03).Value
    ShtTo.Range(C_STR_COL_04 & PostRow).Value = ShtFm.Range(C_PST_ADDR_04).Value
   End If
  Next
 End If
End Sub

Private Function CheckInput(ByVal StartVal As String, ByVal StopVal As String, ByRef Msg As String) As Boolean
 Const C_SHT_NAME_DT As String = "3"  'データシート名
 Const C_PRIMARYKEY As String = "A"  'データシートのPrimaryKey列
 
 Dim DataRowMax As Long        'データシート最大行格納
 Dim ShtDt As Excel.Worksheet     'データシートObject
 
 Set ShtDt = ThisWorkbook.Sheets(C_SHT_NAME_DT)
 'データシートの最大行を取得
 DataRowMax = ShtDt.Range(C_PRIMARYKEY & ShtDt.Rows.Count).End(xlUp).Row
 Msg = ""
 
 If (DataRowMax = 1 And ShtDt.Range(C_PRIMARYKEY & "1").Value = "") Then
  Msg = "データシートにデータがありません。"
 ElseIf Not (IsNumeric(StartVal)) Then
  Msg = "先頭番号には数値を指定してください。"
 ElseIf Not (IsNumeric(StopVal)) Then
  Msg = "最終番号には数値を指定してください。"
 ElseIf (CLng(StartVal) <= 0) Then
  Msg = "先頭の番号が小さすぎます。"
 ElseIf (CLng(StopVal) <= 0) Then
  Msg = "最終の番号が小さすぎます。"
 ElseIf (DataRowMax < CLng(StartVal)) Then
  Msg = "先頭の番号が大きすぎます。"
 ElseIf (DataRowMax < CLng(StopVal)) Then
  Msg = "最終の番号が大きすぎます。"
 ElseIf (CLng(StartVal) > CLng(StopVal)) Then
  Msg = "先頭の番号より最終の番号の方が大きいです。"
 End If
 
 If (Msg = "") Then
  CheckInput = True
 Else
  CheckInput = False
 End If
End Function

【75544】Re:ループ→転記→ループ→転記
お礼  him  - 14/5/13(火) 21:23 -

引用なし
パスワード
   こたつねこ さん

こんばんは。
コードありがとうございました。
試しながら改良してみたいと思います。
行き詰ったらまた再度ご教示お願い致します。

【75545】Re:ループ→転記→ループ→転記
回答  him  - 14/5/13(火) 21:28 -

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


こんばんは。
お世話になります。
下記の通り回答致します。
よろしくお願い致します。


>
>(Q1)「シート3のデータ番号の入力範囲」とは何ですか?
>  1から100 とした場合は、1行目から100行目ということですか?
>  何列目ですか?
   →3列目の3行目からです。


>(Q2)その100個の値を、順にSheet1のB4セルに入れて、
>  その結果の C30,D30,E30,F30 の4つのセルの値を
>  Sheet2に転記する作業を100回繰り返すのですね?
>  →正確にはC30:C40,D30:D40,E30:E40までを転記させたいです。
   

>(Q3)転記先は、どこのセルから始めるのですか?
  →A2、B2、C2、D2へ転記したいです。

【75546】Re:ループ→転記→ループ→転記
発言  γ  - 14/5/13(火) 22:16 -

引用なし
パスワード
   こういうことですか?
骨格だけとお考え下さい。

Sub test()
  Dim x As Long
  Dim y As Long
  
  x = Application.InputBox(prompt:="先頭の番号を入力してください")
  y = Application.InputBox(prompt:="最終の番号を入力してください")

  k = 1
  For i = x To y
    Worksheets("Sheet1").Range("B4").Value = Worksheets("Sheet3").Cells(i + 2, 3).Value
    Worksheets("Sheet1").Range("C30:F30").Copy
    k = k + 1
    Worksheets("Sheet2").Cells(k, 1).PasteSpecial Paste:=xlPasteValues
    For j = 1 To 4
      If Worksheets("Sheet2").Cells(k, j).Value = 0 Then
        Worksheets("Sheet2").Cells(k, j).ClearContents
      End If
    Next
  Next
End Sub

【75550】Re:ループ→転記→ループ→転記
質問  him  - 14/5/15(木) 2:08 -

引用なし
パスワード
   γ さん
こんばんは。
あともう少しご教示お願い致します。

シート2に転記された後、次のデータを転記された最終行の下に次々と転記していきたいのです。(今の状態はデータが転記されたあと、一番上の行に戻って上書きされてしまいます)
どのようにすればいいでしょうか?ご教示よろしくお願い致します。
(説明下手で申し訳ありません)

【75551】Re:ループ→転記→ループ→転記
発言  γ  - 14/5/15(木) 6:18 -

引用なし
パスワード
   A列のデータがある最終のセルは、
シートの最終行から上にジャンプすることで得られます。
Cells(Rows.Count, 1).End(xlUp) ですね。

書き込むのはその直ぐ下ですから、
Cells(Rows.Count, 1).End(xlUp).Offset(1)
です。
これを参考にコードを組み立ててみてください。

【75552】Re:ループ→転記→ループ→転記
質問  him  - 14/5/15(木) 21:47 -

引用なし
パスワード
   こたつねこ さん

こんばんは。
お世話になります。
将来的にコピー範囲も広げていきたいたと思っています。
C30→C30:C40、D30→D30:D40、E30→E30:E40、F30→F30:F40に広げた場合はどのようにしたらいいでしょうか?

ご教示よろしくお願い致します。

【75553】Re:ループ→転記→ループ→転記
発言  γ  - 14/5/15(木) 23:09 -

引用なし
パスワード
   それではこういうことですか?

Sub test2()
  Dim i As Long
  Dim x As Long
  Dim y As Long
  Dim r As Range
  Dim c As Range

  x = Application.InputBox(prompt:="先頭の番号を入力してください")
  y = Application.InputBox(prompt:="最終の番号を入力してください")

  For i = x To y
    '>3列目の3行目からです。(him氏)
    Worksheets("Sheet1").Range("B4").Value _
      = Worksheets("Sheet3").Cells(i + 2, 3).Value

    '> 正確にはC30:C40,D30:D40,E30:E40までを転記させたいです。(him氏)
    'というと、こういうことでOK?
    Worksheets("Sheet1").Range("C30:F40").Copy

    'A列のデータあり最終行の次の行に、値のみ貼り付ける
    With Worksheets("Sheet2")
      Set r = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
    End With
    r.PasteSpecial Paste:=xlPasteValues

    '貼り付けたあとの各セルについて、0 なら 消去 する
    For Each c In r.Resize(11, 4)
      If c.Value = 0 Then
        c.ClearContents
      End If
    Next
  Next
End Sub

【75554】Re:ループ→転記→ループ→転記
回答  こたつねこ  - 14/5/16(金) 21:37 -

引用なし
パスワード
   him さん、こんばんは

>将来的にコピー範囲も広げていきたいたと思っています。
>C30→C30:C40、D30→D30:D40、E30→E30:E40、F30→F30:F40に広げた場合は
>どのようにしたらいいでしょうか?
γさんの質問のおかげで、クリアになった部分も含めて修正しておきます。
こんな感じでどうでしょうか。

標準モジュールにコピーしてお使いください。

Option Explicit

'定数宣言
'------------------------------------------------------------------------
'シート名
Private Const C_SHT_NAME_FM As String = "1"  '転記元シート名
Private Const C_SHT_NAME_TO As String = "2"  '転記先シート名
Private Const C_SHT_NAME_DT As String = "3"  'データシート名
'------------------------------------------------------------------------
'転記元設定
Private Const C_EVT_ADDR_S1 As String = "B4" 'シート1の参照元データ指定セルアドレス
Private Const C_PST_ADDR_01 As String = "C30" 'シート1の転記元アドレス1
Private Const C_PST_ADDR_02 As String = "D30" 'シート1の転記元アドレス2
Private Const C_PST_ADDR_03 As String = "E30" 'シート1の転記元アドレス3
Private Const C_PST_ADDR_04 As String = "F30" 'シート1の転記元アドレス4
Private Const C_PST_ROWS As Long = 11     '転記元データの行数
'------------------------------------------------------------------------
'転記先設定
Private Const C_STR_COL_01 As String = "A"  'シート2の転記先列1
Private Const C_STR_COL_02 As String = "B"  'シート2の転記先列2
Private Const C_STR_COL_03 As String = "C"  'シート2の転記先列3
Private Const C_STR_COL_04 As String = "D"  'シート2の転記先列4
Private Const C_ROW_POSTSTART As Long = 2   '転記開始行 ex:2行目から転記開始
'------------------------------------------------------------------------
'データシート設定
Private Const C_PRIMARYKEY As String = "C"  'データシートのPrimaryKey列
Private Const C_ROW_DATASTART As Long = 3   'データ開始行
'------------------------------------------------------------------------


Public Sub sample()
 Dim ShtTo As Excel.Worksheet     '転記先シートObject
 Dim ShtFm As Excel.Worksheet     '転記元シートObject
 Dim StartNo As String         '先頭データ指定番号格納
 Dim StopNo As String         '最終データ指定番号格納
 Dim TargetNo As Long         '処理対象データ番号格納
 Dim PostRow As Long          '転記先行番号格納用
 Dim FlgPost As Boolean        '転記判定用フラグ
 Dim Msg As String           'エラーメッセージ格納
 
 '追加***************************Start
 Dim ShtDt As Excel.Worksheet
 Dim PostVal01 As Variant
 Dim PostVal02 As Variant
 Dim PostVal03 As Variant
 Dim PostVal04 As Variant
 Dim LoopRow As Long
 Dim DataRow As Long
 '追加***************************End
 
 '対象データの先頭と最終を取得
 StartNo = Application.InputBox(prompt:="先頭の番号を入力してください")
 StopNo = Application.InputBox(prompt:="最終の番号を入力してください")
 
 If (CheckInput(StartNo, StopNo, Msg) = False) Then
  MsgBox Msg, vbCritical, "エラー"
 Else
  Set ShtTo = ThisWorkbook.Sheets(C_SHT_NAME_TO)
  Set ShtFm = ThisWorkbook.Sheets(C_SHT_NAME_FM)
  Set ShtDt = ThisWorkbook.Sheets(C_SHT_NAME_DT)
  
  '入力された先頭番号から最終番号の間繰り返す
  For TargetNo = CLng(StartNo) To CLng(StopNo)
   'データ番号からデータシートの行数を計算
   DataRow = TargetNo + C_ROW_DATASTART - 1
   
   '転記元シートの参照先指定セルに番号をセット
   ShtFm.Range(C_EVT_ADDR_S1).Value = ShtDt.Range(C_PRIMARYKEY & CStr(DataRow)).Value
   
   '変更***************************Start
   
   '転記元のデータを各列ごとに一旦配列に取込む
   PostVal01 = ShtFm.Range(C_PST_ADDR_01).Resize(C_PST_ROWS).Value
   PostVal02 = ShtFm.Range(C_PST_ADDR_02).Resize(C_PST_ROWS).Value
   PostVal03 = ShtFm.Range(C_PST_ADDR_03).Resize(C_PST_ROWS).Value
   PostVal04 = ShtFm.Range(C_PST_ADDR_04).Resize(C_PST_ROWS).Value
   
   For LoopRow = 1 To C_PST_ROWS
   
    '転記判定フラグを転記するにセット
    FlgPost = True
    
    '条件:値0がある場合は転記判定フラグを転記しないにセット
    If (PostVal01(LoopRow, 1) = 0) Then
     FlgPost = False
    ElseIf (PostVal02(LoopRow, 1) = 0) Then
     FlgPost = False
    ElseIf (PostVal03(LoopRow, 1) = 0) Then
     FlgPost = False
    ElseIf (PostVal04(LoopRow, 1) = 0) Then
     FlgPost = False
    End If
    
    '転記判定フラグが転記するの場合転記
    If (FlgPost) Then
     '転記先行番号取得
     PostRow = ShtTo.Range(C_STR_COL_01 & ShtTo.Rows.Count).End(xlUp).Offset(1, 0).Row
     
     'データがない場合は【C_ROW_POSTSTART】で指定した行数
     If (PostRow < C_ROW_POSTSTART) Then PostRow = C_ROW_POSTSTART
     
     '転記
     ShtTo.Range(C_STR_COL_01 & PostRow).Value = PostVal01(LoopRow, 1)
     ShtTo.Range(C_STR_COL_02 & PostRow).Value = PostVal02(LoopRow, 1)
     ShtTo.Range(C_STR_COL_03 & PostRow).Value = PostVal03(LoopRow, 1)
     ShtTo.Range(C_STR_COL_04 & PostRow).Value = PostVal04(LoopRow, 1)
    End If
   Next
  Next
 End If
End Sub

Private Function CheckInput(ByVal StartVal As String, ByVal StopVal As String, ByRef Msg As String) As Boolean
 Dim DataRowMax As Long        'データシート最大行格納
 Dim ShtDt As Excel.Worksheet     'データシートObject

 Set ShtDt = ThisWorkbook.Sheets(C_SHT_NAME_DT)
 'データシートの最大行を取得
 DataRowMax = ShtDt.Range(C_PRIMARYKEY & ShtDt.Rows.Count).End(xlUp).Row
 Msg = ""

 If (DataRowMax < C_ROW_DATASTART And ShtDt.Range(C_PRIMARYKEY & "1").Value = "") Then
  Msg = "データシートにデータがありません。"
 ElseIf Not (IsNumeric(StartVal)) Then
  Msg = "先頭番号には数値を指定してください。"
 ElseIf Not (IsNumeric(StopVal)) Then
  Msg = "最終番号には数値を指定してください。"
 ElseIf (CLng(StartVal) <= 0) Then
  Msg = "先頭の番号が小さすぎます。"
 ElseIf (CLng(StopVal) <= 0) Then
  Msg = "最終の番号が小さすぎます。"
 ElseIf (DataRowMax < CLng(StartVal)) Then
  Msg = "先頭の番号が大きすぎます。"
 ElseIf (DataRowMax < CLng(StopVal)) Then
  Msg = "最終の番号が大きすぎます。"
 ElseIf (CLng(StartVal) > CLng(StopVal)) Then
  Msg = "先頭の番号より最終の番号の方が大きいです。"
 End If

 If (Msg = "") Then
  CheckInput = True
 Else
  CheckInput = False
 End If
End Function

【75570】Re:ループ→転記→ループ→転記
お礼  him  - 14/5/18(日) 17:40 -

引用なし
パスワード
   こたつねこ さん
こんにちは。
返信が遅くなり申し訳ありません。
新たなコードありがとうございます。
感謝致します。

【75573】Re:ループ→転記→ループ→転記
発言  γ  - 14/5/18(日) 22:27 -

引用なし
パスワード
   14/5/15(木) 23:09 にもコメントしています。
読み飛ばさないで頂きたい。

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