| |
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" 'シート１の参照元データ指定セルアドレス
Private Const C_PST_ADDR_01 As String = "C30" 'シート１の転記元アドレス１
Private Const C_PST_ADDR_02 As String = "D30" 'シート１の転記元アドレス２
Private Const C_PST_ADDR_03 As String = "E30" 'シート１の転記元アドレス３
Private Const C_PST_ADDR_04 As String = "F30" 'シート１の転記元アドレス４
Private Const C_PST_ROWS As Long = 11 '転記元データの行数
'------------------------------------------------------------------------
'転記先設定
Private Const C_STR_COL_01 As String = "A" 'シート２の転記先列１
Private Const C_STR_COL_02 As String = "B" 'シート２の転記先列２
Private Const C_STR_COL_03 As String = "C" 'シート２の転記先列３
Private Const C_STR_COL_04 As String = "D" 'シート２の転記先列４
Private Const C_ROW_POSTSTART As Long = 2 '転記開始行 ex:２行目から転記開始
'------------------------------------------------------------------------
'データシート設定
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
'条件：値０がある場合は転記判定フラグを転記しないにセット
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
|
|
こたつねこ
- 14/5/16(金) 21:37 -
