• 締切済み

vbaプログラミングについて教えてください。

vba初心者です。下記のようにプログラミングしましたがもっといいプログラムの仕方はないでしょうか。ちょっとごちゃごちゃしていて見にくいです。どなかたお力をお貸しください。 Private Sub データUPDATE輸入_Click() ActiveSheet.Unprotect Dim Line As String Dim Maxrow As String Sheets("Invoice").Select Line = 5   Do Until Cells(Line, 7).Value = "" On Error Resume Next 'A列の空欄をコピーして埋める If Cells(5, 1).Value = "" Then Cells(Line, 1).Value = "" ElseIf Cells(Line, 1).Value = "" Then Cells(Line, 1).Value = Cells(Line - 1, 1).Value End If 'B列の空欄をコピーして埋める If Cells(5, 2).Value = "" Then Cells(Line, 2).Value = "" ElseIf Cells(Line, 2).Value = "" Then Cells(Line, 2).Value = Cells(Line - 1, 2).Value End If 'C列の空欄をコピーして埋める If Cells(5, 3).Value = "" Then Cells(Line, 3).Value = "" ElseIf Cells(Line, 3).Value = "" Then Cells(Line, 3).Value = Cells(Line - 1, 3).Value End If 'D列の空欄をコピーして埋める If Cells(5, 4).Value = "" Then Cells(Line, 4).Value = "" ElseIf Cells(Line, 4).Value = "" Then Cells(Line, 4).Value = Cells(Line - 1, 4).Value End If 'E列の文字を「輸入シート」から検索しF列に貼り付ける If Cells(Line, 5).Value = "" Then Cells(Line, 5).Value = Cells(Line - 1, 5).Value End If Cells(Line, 6).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 2, 0) 'E列を検索しデータが存在しない場合はF列に「データがありません」を表記 If Cells(Line, 6).Value = "" Then Cells(Line, 6).Value = "データがありません" GoTo コピー貼り付け End If コピー貼り付け: If Cells(Line, 6).Value = "データがありません" Then Cells(Line, 5).Copy 'コピーする Maxrow = Worksheets("輸入Parts").Range("A1").End(xlDown).Row + 1 Worksheets("輸入Parts").Range("A" & Maxrow).PasteSpecial Paste:=xlPasteValues '値を貼り付け End If 'H列の空欄をコピーして埋める If Cells(5, 12).Value = "" Then Cells(Line, 12).Value = "" ElseIf Cells(Line, 12).Value = "" Then Cells(Line, 12).Value = Cells(Line - 1, 12).Value End If 'E列の文字を「輸入シート」から検索しZ列に貼り付ける Cells(Line, 26).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 3, 0) 'E列を検索しデータが存在しない場合はZ列に「データがありません」を表記 If Cells(Line, 26).Value = "" Then Cells(Line, 26).Value = "データがありません" End If 'AD列の空欄をコピーして埋める If Cells(5, 30).Value = "" Then Cells(Line, 30).Value = "" ElseIf Cells(Line, 30).Value = "" Then Cells(Line, 30).Value = Cells(Line - 1, 30).Value End If 'E列の文字を「輸入シート」から検索しAM列に貼り付ける Cells(Line, 39).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 18, 0) 'E列を検索しデータが存在しない場合はAM列に「データがありません」を表記 If Cells(Line, 39).Value = "" Then Cells(Line, 39).Value = "データがありません" End If '「Unit price」の計算・円建と外貨建が合わさったインボイスの場合の合計金額 If Cells(Line, 14).Value = "" Then Cells(Line, 13).Value = Cells(Line, 17).Value * Cells(Line, 33).Value / Cells(Line, 7).Value Else Cells(Line, 17).Value = Application.WorksheetFunction.RoundDown(Cells(Line, 14).Value * Cells(Line, 16), 0) Cells(Line, 15).Value = Cells(Line, 16).Value * Cells(Line, 33).Value / Cells(Line, 7).Value End If 'T.Invoice Priceの計算 Cells(Line, 23).Value = Application.WorksheetFunction.Sum(Cells(Line, 17), Cells(Line, 18), Cells(Line, 19), Cells(Line, 20), Cells(Line, 21), Cells(Line, 22)) 'VLOOKUP関数が終わり、エラーが発生したら止まる On Error GoTo 0 '次の行に移り最後の行まで検索 Line = Line + 1 Loop End Sub

みんなの回答

回答No.2

VBAでExcelオブジェクトを操作する場合は、オブジェクト(CellやRangeなど)の参照は 時間がかかる為、極力少ない方がベターです。 また、Rangeの文字列指定による参照はパフォーマンスをかなり落とすので、利用しない事がベターです。 色々いじるセルがあるようですから、恐らく、下記ようにして、予め対象行の対象セルを 全部Rangeに入れておいて、そのオブジェクトを使いまわす、がいいかもしれません。 Dim CellSetGroup1 As Range Dim CellSetGroup2 As Range Set CellSetGroup1 = Range(Cells(line, 1), Cells(line, 6)) ' A列~F列 Set CellSetGroup2 = Range(Cells(line, 10), Cells(line, 15)) ' J列~O列 MsgBox CellSetGroup1(1).Value ' A1の値を出力 みたいな。 いじってて他に思ったのは、以下の点です。  ・プロシージャを分けて、責任範疇を狭める。  ・マジックナンバーは行わない。   5とか7って言われてもどこの列を参照しているのか不透明です。   全て必要な列はenumを利用するなどして定義するべきでしょう。  ・Line、MaxRowの型が数値型ではない。正しい型宣言にするべき。  ・リテラル文字は定数定義に変えるべき。   "輸入Parts"とか"A2:R20000"とか。 以下、それっぽくリファクタしたコードです。動くのかどうか知りませんし、 何をどうしたいのか理解した上でいじったわけではないので、もっと色んな場所で 改善の余地があると思います。 Private Sub データUPDATE輸入_Click() On Error GoTo Exception Dim line As Long Dim maxRow As Long ActiveSheet.Unprotect Sheets("Invoice").Select line = 5 Do Until Cells(line, 7).Value = "" ' 他のセルを考慮した値出力 Call putJudgeCells(line) ' E列 Call putPreviousCellValue(line, 5) ' 輸入シート関係 Call putSearchCellValue(line) '「Unit price」の計算・円建と外貨建が合わさったインボイスの場合の合計金額 If Cells(line, 14).Value = "" Then Cells(line, 13).Value = Cells(line, 17).Value * Cells(line, 33).Value / Cells(line, 7).Value Else Cells(line, 17).Value = Application.WorksheetFunction.RoundDown(Cells(line, 14).Value * Cells(line, 16), 0) Cells(line, 15).Value = Cells(line, 16).Value * Cells(line, 33).Value / Cells(line, 7).Value End If 'T.Invoice Priceの計算 Cells(line, 23).Value = Application.WorksheetFunction.Sum(Cells(line, 17), Cells(line, 18), Cells(line, 19), Cells(line, 20), Cells(line, 21), Cells(line, 22)) '次の行に移り最後の行まで検索 line = line + 1 Loop Exit Sub Exception: Call MsgBox(Err.Description) End Sub '/** ' * 他セル値を考慮するセルの値を出力を行う ' * @param row 行 ' * @param column 列 ' */ Private Sub putJudgeCells(row As Long) ' A, B, C, D, H, AD列 For Each column In Array(1, 2, 3, 4, 12, 30) Call putJudgeCellValue(row, CLng(column)) Next End Sub '/** ' * 他セル値を考慮して値を出力する ' * @param row 行 ' * @param column 列 ' */ Private Sub putJudgeCellValue(row As Long, column As Long) ' 5行目のセル判断 With Cells(row, column) If Cells(5, column).Value = "" Then .Value = "" Exit Sub End If End With Call putPreviousCellValue(row, column) End Sub '/** ' * 対象セルの前行セルから値を出力する ' * @param row 行 ' * @param column 列 ' */ Private Sub putPreviousCellValue(row As Long, column As Long) With Cells(row, column) If .Value = "" Then .Value = .Offset(-1, 0).Value End If End With End Sub '/** ' * 輸入シートから検索を行い、セルの値を出力する ' * @param row 行 ' * @param column 列 ' */ Private Sub putSearchCellValue(row As Long) Dim maps(1 To 3) As Variant maps(1) = Array(6, 2) maps(2) = Array(26, 3) maps(3) = Array(39, 18) For Each map In maps With Cells(row, CLng(map(0))) .Value = getInWareHouse(line, map(1)) If .Value = "" Then .Value = "データがありません" ' F列の場合、輸入シートにセルコピー If map(0) = 6 Then Call copyUnmatchKey(row) End If End If End With Next End Sub '/** ' * E5の値から「輸入シート」から対象データを検索する ' * @param row 行 ' * @param targetColumn 取得列 ' */ Private Function getInWareHouse(row As Long, targetColumn As Long) As String On Error GoTo Exception getInWareHouse = Application.WorksheetFunction.VLookup( _ Cells(row, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), targetColumn, False) Exit Function Exception: If Err.Number = 1004 Then getInWareHouse = "" Exit Function Else Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) End If End Function '/** ' * 輸入シート不一致の場合、輸入シートにコピーする ' * @param row 行 ' */ Private Sub copyUnmatchKey(row As Long) Dim maxRow As Long Cells(row, 5).Copy maxRow = Worksheets("輸入Parts").Range("A1").End(xlDown).row + 1 Worksheets("輸入Parts").Range("A" & maxRow).PasteSpecial Paste:=xlPasteValues End Sub

lovelyLeoKun
質問者

お礼

こんなにすっきりとしたプログラミングになるんですね。ご指導ありがとうございました。参考にさせていただきます。

  • eden3616
  • ベストアンサー率65% (267/405)
回答No.1

(1)同じような処理は変数でまとめる。 「○列の空欄をコピーして埋める」の処理は全て一つにまとめれます。 たとえば、配列変数 = Split("A,B,C,D,L,AD", ",") For Each 変数 in 配列変数 ~ Next (内部のCellはRangeに変更) のようにして一つのコード内で変数を回し、纏めることが出来ます。 (2)不要な処理を入れない。 以下の処理でIf ~ End Ifが終われば次のコードへ処理が移動するので Go To~やラベルは不要です。 また、処理1のなかに処理2を入れる。 If Cells(Line, 6).Value = "" Then   ~処理1~   Cells(Line, 6).Value = "データがありません"   GoTo コピー貼り付け End If コピー貼り付け: If Cells(Line, 6).Value = "データがありません" Then   ~処理2~ End IF (3)一つのオブジェクトに対する処理はWith オブジェクト~End Withを使用 With~End Withを使えば極端かもしれませんが以下のように記述できます。 (場合によっては可読性が悪くなります) 'D列の空欄をコピーして埋める With Cells(Line, 4)   If Cells(5, 4).Value = "" Then     .Value = ""   ElseIf .Value = "" Then     .Value = .Offset(-1, 0).Value   End If End With (4)オブジェクト変数に代入してコードを短くする 以下のように変数へオブジェクトを代入すれば変数で範囲を利用できます。 Set オブジェクト変数 = Worksheets("輸入Parts").Range("A2:R20000")       ↓ Cells(Line, 26).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, オブジェクト変数, 3, 0) (5)Range or Cells オブジェクトのValueプロパティは省略可能   RangeやCellsでセル指定した場合のValueプロパティは標準で取得されますので   省略できますが、Valueである認識はもっておく必要があります   またWith~End Withなどでオブジェクトを省略した場合はValueが必要 こんなところを注意して無駄になっているコード 繰り返し同じことをしているコード などを最適化してください。ぐっと短いコードになると思います。

lovelyLeoKun
質問者

お礼

ご指導ありがとうございました。まだまだ知らないことが多いのでもっと勉強します。

関連するQ&A