Excel VBA質問箱 IV

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

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


6777 / 76734 ←次へ | 前へ→

【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

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

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