Excel VBA質問箱 IV

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

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


6791 / 76734 ←次へ | 前へ→

【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

7 hits

【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 発言

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