| |
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" 'シート１の参照元データ指定セルアドレス
Const C_PST_ADDR_01 As String = "C30" 'シート１の転記元アドレス１
Const C_PST_ADDR_02 As String = "D30" 'シート１の転記元アドレス２
Const C_PST_ADDR_03 As String = "E30" 'シート１の転記元アドレス３
Const C_PST_ADDR_04 As String = "F30" 'シート１の転記元アドレス４
Const C_STR_COL_01 As String = "A" 'シート２の転記先列１
Const C_STR_COL_02 As String = "B" 'シート２の転記先列２
Const C_STR_COL_03 As String = "C" 'シート２の転記先列３
Const C_STR_COL_04 As String = "D" 'シート２の転記先列４
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
'条件：値０がある場合は転記判定フラグを転記しないにセット
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
|
|
こたつねこ
- 14/5/12(月) 22:41 -
