Deprecated: The each() function is deprecated. This message will be suppressed on further calls in /home/zhenxiangba/zhenxiangba.com/public_html/phproxy-improved-master/index.php on line 456
入力したデータを転記する:Excel VBA プログラミング入門

入力したデータを転記する:Excel VBA プログラミング入門

ここでは、Excel VBAで入力したデータを他シートへ転記するコードを作成してみます。

スポンサードリンク

はじめに

以下にコードを書いていますが、ドット(.)やカンマ(,)、コロン(:)やセミコロン(;)など見づらかったりしますので、見落としや見間違いに注意してください。
「入力」シートにデータを入力します。
- 入力シートにはA1:D1のように列見出しを入力しています。
  A列には日付が入りますので、A列の表示形式を「*2001/3/14」としておきます。
  C:E列は「桁区切りスタイル」を設定しておきます。
  データはA2:D2へ入力します。
「データ」シートに入力したデータを転記します。
- 「データ」シートにはA1:E1のように列見出しを入力しています。
  A列には日付が入りますので、A列の表示形式を「*2001/3/14」としておきます。
  C:E列は「桁区切りスタイル」を設定しておきます。
- 転記するデータはA2以降に転記します。

値を転記するコードの作成例

入力シートの値をデータシートへ転記します。
- 左辺に転記先、右辺に転記元を指定します。
  このとき、A2:D2のセル範囲をまとめて転記しますので、左辺と右辺のセル数が一致していることに注意してください。
  
  Sub prog2()
  　　Worksheets("データ").Range("A2:D2").Value = Worksheets("入力").Range("A2:D2").Value
  End Sub
- A2セルから4列分のデータですので、Resize プロパティを使って以下のように書くこともできます。
  A2セルを基準として、行は1行、列は4列までセル範囲を変更しますので、Range("A2").Resize(1, 4)でA2:D2のセル範囲となります。
  
  Sub prog2()
  　　Worksheets("データ").Range("A2").Resize(1, 4).Value = Worksheets("入力").Range("A2").Resize(1, 4).Value
  End Sub
- 実行画面
  1. 入力シートのA2:D2に入力後、「prog2」を実行します。
  2. データシートA2:D2セルに入力シートA2:D2の値が転記されました。
[Point]　セルに値を入れるでちょっと丁寧に説明しています。

金額の計算をする

金額=単価×数量ですので、入力シートのC2*D2　で計算できます。コードは以下のようになります。

Sub prog3()
　　Worksheets("データ").Range("A2:D2").Value = Worksheets("入力").Range("A2:D2").Value
　　Worksheets("データ").Range("E2").Value = Worksheets("入力").Range("C2").Value * Worksheets("入力").Range("D2").Value
End Sub

非常に見づらいものとなってしまいましたので、ワークシートを変数Sh1、Sh2と指定して書き直してみます。
結構、見やすくなったと思いませんか？

Sub prog3()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　Sh2.Range("A2:D2").Value = Sh1.Range("A2:D2").Value
　　　　　　Sh2.Range("E2").Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
End Sub

さらに、Sh2への転記が主とみて、Withステートメントを使ってSh2目線で書き直してみます
.Range("A2：D2").Valueの最初にドットを付け忘れてはいけません。
コードの行が増えましたが、さらに見やすくなったと思いませんか？

Sub prog3()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　With Sh2
　　　　　　　　.Range("A2:D2").Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E2").Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
　　　　　　End With
End Sub

シート内で計算をすることもできます。

Sheet2のE2セルには=C2*D2とすればよいのですから、その数式を入れてやればよいと考えたら、以下のようになります。

Sub prog3_2()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　With Sh2
　　　　　　　　.Range("A2:D2").Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E2").Formula = "=C2*D2"
　　　　　　End With
End Sub

でも、数式は残したくない、値だけでよいと考えたら、以下のようにすることができます。

データを最下行に追加する

これまでのコードでは常にA2:E2へデータが転記されるだけですので、データシートの最下行に追加したいと思います。

最下行を求めるには?

転記先の行番号を変数myRowを利用して求めたいと思います。
シートのA列の最終行「.Range("A" & Rows.Count)」から、上の方へ入力データを捜し、その行番号を取得します。
myRow = .Range("A" & Rows.Count).End(xlUp).Row
となります。このmyRowは入力データの最下行の行番号です。
- 逆に「myRow = .Range("A1").End(xlDown).Row」で求めてもよさそうですが、データが１個もないときはシートの最終行（Excel2003以前では65536,Excel2007では1048576)を返してしまい、ちょっと不都合な時があります。
データを追記するのは最下行の次の行ですので、転記先の行番号は
myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
と、+ 1 する必要があります。

さらに、コード内の転記先もmyRowで置き換えると以下のようになります。

Sub prog4()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim myRow As Long
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　With Sh2
　　　　　　　　myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　.Range("A" & myRow & ":D" & myRow).Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E" & myRow).Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
　　　　　　End With
End Sub

.Range("A" & myRow & ":D" & myRow).Value = Sh1.Range("A2:D2").Value
↓
.Range(.Range("A" & myRow), .Range("D" & myRow)).Value = Sh1.Range("A2:D2").Value
のように書いた方がわかりやすいかもしれません。
.Range("A" & myRow)　 .Range("D" & myRow)　両方とも前にドットを忘れないようにしてください。
WithステートメントでSh2を指定しているのですから、「.」が無いとアクティブシート(この場合Sh1)のセルを指してしまいます。

これで、データシートの最下行の下へデータが逐次転記されるようになりました。

転記後入力データをクリアする

データを入力して、転記したら次のデータを入力したい・・・。
すると、前の入力データが残っていますのでこれをクリアしないと不便ですし、間違ってマクロを実行すると重複して転記されてしまいます。

転記後に、入力シートの入力データをクリアします。

Sub prog4()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim myRow As Long
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　With Sh2
　　　　　　　　myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　 .Range(.Range("A" & myRow), .Range("D" & myRow)).Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E" & myRow).Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
　　　　　　End With
　　　　　　With Sh1
　　　　　　　　.Range("A2:D2").ClearContents
　　　　　　End With
End Sub

入力データの適否を判定する

A2セルは日付が入力されているか、B2セルは未入力ではないか、C2:D2セルは数値が入力されているか、を調べます。
これらが以上である時はメッセージボックスを表示し、コードを終了します。

以下のようなコードにしてみました。

Sub prog5()
　　Dim Sh1 As Worksheet
　　　　Set Sh1 = Worksheets("入力")
　　　　　　With Sh1
　　　　　　　　If IsDate(.Range("A2").Value) = False Then
　　　　　　　　　　MsgBox "A2セルには日付を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If .Range("B2").Value = "" Then
　　　　　　　　　　MsgBox "B2セルが未入力です!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If IsNumeric(.Range("C2").Value) = False Or .Range("C2").Value = "" Then
　　　　　　　　　　MsgBox "C2セルには数値を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If IsNumeric(.Range("D2").Value) = False Or .Range("D2").Value = "" Then
　　　　　　　　　　MsgBox "D2セルには数値を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　End With
End Sub

まとめ

上記までにできたコード、prog4とprog5を繋いで実行するようにします。

Sub データの転記()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim myRow As Long
　　　Set Sh1 = Worksheets("入力")
　　　Set Sh2 = Worksheets("データ")
　　　　　　'入力データのチェックを行います
　　　　　　With Sh1
　　　　　　　　If IsDate(.Range("A2").Value) = False Then
　　　　　　　　　　MsgBox "A2セルには日付を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If .Range("B2").Value = "" Then
　　　　　　　　　　MsgBox "B2セルが未入力です!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If IsNumeric(.Range("C2").Value) = False Or .Range("C2").Value = "" Then
　　　　　　　　　　MsgBox "C2セルには数値を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If IsNumeric(.Range("D2").Value) = False Or .Range("D2").Value = "" Then
　　　　　　　　　　MsgBox "D2セルには数値を入力します!!"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　End With
　　　　　　’入力データを転記します
　　　　　　With Sh2
　　　　　　　　myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　.Range(.Range("A" & myRow), .Range("D" & myRow)).Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E" & myRow).Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
　　　　　　End With
　　　　　　With Sh1
　　　　　　　　.Range("A2:D2").ClearContents
　　　　　　End With
End Sub

prog5を以下のようにFunctionプロシージャにすると、以下のように処理することもできます。

Sub データの転記2()
　　If 判定 Then prog4
End Sub

または、prog4のコードの最初の方で、「判定」をしてFalseの場合は終了するという方法も考えられます。

Sub データの転記3()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim myRow As Long
　　　　If 判定 = False Then Exit Sub
　　　　Set Sh1 = Worksheets("入力")
　　　　Set Sh2 = Worksheets("データ")
　　　　　　With Sh2
　　　　　　　　myRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　 .Range(.Range("A" & myRow), .Range("D" & myRow)).Value = Sh1.Range("A2:D2").Value
　　　　　　　　.Range("E" & myRow).Value = Sh1.Range("C2").Value * Sh1.Range("D2").Value
　　　　　　End With
　　　　　　With Sh1
　　　　　　　　.Range("A2:D2").ClearContents
　　　　　　End With
End Sub

Function 判定() As Boolean
　　Dim Sh1 As Worksheet
　　　　Set Sh1 = Worksheets("入力")
　　　　判定 = True
　　　　With Sh1
　　　　　　If IsDate(.Range("A2").Value) = False Then
　　　　　　　　MsgBox "A2セルには日付を入力します!!"
　　　　　　　　判定 = False: Exit Function
　　　　　　End If
　　　　　　If .Range("B2").Value = "" Then
　　　　　　　　MsgBox "B2セルが未入力です!!"
　　　　　　　判定 = False: Exit Function
　　　　　　End If
　　　　　　If IsNumeric(.Range("C2").Value) = False Or .Range("C2").Value = "" Then
　　　　　　　　MsgBox "C2セルには数値を入力します!!"
　　　　　　　　判定 = False: Exit Function
　　　　　　End If
　　　　　　If IsNumeric(.Range("D2").Value) = False Or .Range("D2").Value = "" Then
　　　　　　　　MsgBox "D2セルには数値を入力します!!"
　　　　　　　　判定 = False: Exit Function
　　　　　　End If
　　　　End With
End Function

スポンサードリンク

よねさんのWordとExcelの小部屋｜Excel VBA プログラミング入門：目次｜入力したデータを転記する

PageViewCounter
　 Counter
　Since2006/2/27