dポイントプレゼントキャンペーン実施中！

マクロを簡潔にしたいので教えてください。

解決済

  • 質問者：noname#178407
  • 質問日時：
  • 回答数：6件

Sub 記入()
Dim testno As String
Dim testrow As Long
Dim basedata(1 To 10) As String
Dim weight(1 To 16) As Double
Sheets("sh3").Select

'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If

For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i

'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sheet3").Select
Cells(3, 1) = testno
For i = 1 To 10
Cells(3, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(3, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight

'(1)
testno = Range("B24").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If

For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i

'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(4, 1) = testno
For i = 1 To 10
Cells(4, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(4, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight

この間同様文12個あり
'(1)
testno = Range("B37").Value
If testno = "" Then
End
End If

Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If

For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i

'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(17, 1) = testno
For i = 1 To 10
Cells(17, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(17, i + 11) = weight(i)
Next i
End Sub

通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (6件)

No.5ベストアンサー

  • 回答者： cj_mover
  • 回答日時：

こんにちは。

お邪魔します。

やり過ぎない程度に簡潔な形で全体を書いてみました。
一応、ダミーサンプルブックを作成して簡単に動作確認しています。
ご提示のコードが期待通りの結果を返す前提で、なるべく原形を残して
翻訳（ほぼ直訳）に徹しているつもりですが、期待通りでなかったら、
コードでなく言葉で、こちらが解る様に説明してください。
書く人の数だけ多様に書ける処理ですが、
私のは、最適化というほどのことはしていません。
ただ、投稿されたカテゴリが- MS Office -ですので、
ＶＢＡらしい書き方を意識しています。
Visual Basic for Applications 的であって、Visual Basic 的ではない書き方です。
なるべく、ご提示のコードを書いた人なら理解できるであろう書き方で、
簡潔になるよう心がけて書いています。

せっかく配列を使っているのに、、、と思える部分が
２カ所ありましたので、配列変数を使うメリットを強調する意味で
配列のまま関数の引数にしたり、配列のままセル範囲に出力したり、
という点を重点に書き換えています。

sh1、sh2、にてtestNoがヒットしない場合は、すべての処理を終了する
という動作仕様で書かれているようなので、サブルーチンをFunctionにして
不正の場合にTrueを返して判別後 Exit Sub するように書きました。

メインプロシージャの記述から
　　For i = 3 To 17
　　　　If 記入sub(i) Then MsgBox ("?"): Exit Sub
　　Next i
の部分の カウンタ i についてだけ説明を。
　　testNo = Trim(Cells(printRow + 20, "B"))
これで
Sheets("sh3") の Range("B23") から Range("B37") までを
順に、testNo として、
Sheets("sh3") の ３行めから17行めに結果を出力するように
ループしていることになります。

VBAに詳しくなるまでは、End ステートメントの使用は避けた方が無難です。
正しく理解した上で使わないと何かとトラブルの元になりますし、
End ステートメントを使う必要は、かなり特殊で、普通は（VBAでは）使いません。
Exit Sub を使うようにしましょう。

必ず疑問が残るでしょから、初歩的なことはご自分で調べて確かめるなり、
応用的なことはこちらに質問するなりして、自分のものにするように努めてください。

シート名は"sh1"..？　"Sheet1"..？◆シート名◆３カ所、必要なら修正してください。

実行するのは、Sub 記入main()　です。

Sub 記入main() ' Re8072449
　　Dim i As Long

　　Sheets("sh3").Select ' ◆シート名◆
　　Range("A3:AA17").ClearContents ' 前回作成したデータを消去する？

　　Application.ScreenUpdating = True ' ←少しでも速く処理したい場合。お好みで
　　For i = 3 To 17
　　　　If 記入sub(i) Then MsgBox "?": Exit Sub
　　Next i
End Sub

Private Function 記入sub(ByVal printRow As Long) As Boolean
　　Dim baseData(0 To 10) As String ' baseData(0) は testNo 用に予め確保
　　Dim testNo As String
　　Dim weightA(1 To 6) As Double ' 配列変数 weight を３つに分ける
　　Dim weightB(7 To 12) As Double
　　Dim weightC(13 To 16) As Double
　　Dim testRow As Long
　　Dim i As Long

　　testNo = Trim(Cells(printRow + 20, "B"))

　　With Sheets("sh1") ' ◆シート名◆
　　　　For testRow = .Cells(65536, 1).End(xlUp).Row To 6 Step -1
　　　　　　If CStr(.Cells(testRow, 1)) = testNo Then Exit For
　　　　Next testRow
　　　　If testRow < 6 Then 記入sub = True: Exit Function

　　　　For i = 1 To 10
　　　　　　baseData(i) = .Cells(testRow, i + 1)
　　　　Next i
　　End With

　　With Sheets("sh2") ' ◆シート名◆
　　　　For testRow = .Cells(65536, 1).End(xlUp).Row To 6 Step -1
　　　　　　If CStr(.Cells(testRow, 1)) = testNo Then Exit For
　　　　Next testRow
　　　　If testRow < 6 Then 記入sub = True: Exit Function

　　　　For i = 1 To 6
　　　　　　weightA(i) = .Cells(testRow, i + 1)
　　　　Next i
　　　　For i = 7 To 12
　　　　　　weightB(i) = .Cells(testRow, i + 2)
　　　　Next i
　　End With

　　baseData(0) = testNo

　　weightC(13) = Application.Max(weightA)
　　weightC(14) = Application.Min(weightA)
　　weightC(15) = Application.Max(weightB)
　　weightC(16) = Application.Min(weightB)

　　Cells(printRow, 1).Resize(, 11).Value = baseData ' Sheets("sh3")　Select済
　　Cells(printRow, 12).Resize(, 6).Value = weightA
　　Cells(printRow, 18).Resize(, 6).Value = weightB
　　Cells(printRow, 24).Resize(, 4).Value = weightC

　　Erase baseData, weightA, weightB, weightC ' ←プロシージャの最終行なら省略可
End Function
    • good
    • 0
    • 件
通報する
この回答へのお礼

今起動させてもらいました。四苦八苦しながらテキストやネットを参考にしながら作成したもので、意味もわからず記入していたところがありました。本当に有難うございました。言葉で表せなかったことで皆様にご迷惑をお掛けしました。
こんなに遅い時間にもかかわらず回答いただき有難うございました。

通報する
お礼日時：2013/05/05 00:22

No.6

  • 回答者： hallo-2007
  • 回答日時：

さて、次はサブルーチンについて調べてみてください


VBA Call とかで検索してみてください。

新しいモジュールで、以下をコピーしてみてください。

Dim testrow As Long

Sub ボタン1_Click()
testno = Range("B23").Value 'No.
Sheets("sh1").Select

Call 検索(testno)
MsgBox Testrow
End Sub

Sub 検索(testno)
Set res =Column("A:A").Find(What:=testno, After:=Range("A1"), LookAt:=xlWhole, SearchDirection:=xlPrevious)
testrow = res.Row
End Sub

これを理解したら、だいぶ短いコードになるでしょう。
後は、先に紹介した最大値などの取得の仕方を見直してください。
    • good
    • 0
    • 件
通報する
この回答へのお礼

何度も回答いただき有難うございました。無事解決いたしました。言葉での説明が足らないにもかかわらずご指導いただき感謝いたします。

通報する
お礼日時：2013/05/05 00:25

No.4

  • 回答者： hallo-2007
  • 回答日時：

NO2です。


Ｆｉｎｄ関数の使い方が
http://excelvba.pc-users.net/fol7/7_1.html
にありますので、参考にしてください。

Sub 検索()
testno = Range("B23").Value 'No.
Sheets("sh1").Select
Columns("A:A").Find(What:=testno, After:=Range("A1"), LookAt:=xlWhole, SearchDirection:=xlPrevious).Activate
End Sub

をコピーして実行してみてください。
ご希望のセルがアクティブになっていませんか？
    • good
    • 0
    • 件
通報する
この回答へのお礼

こんばんは、すごくコンパクトに纏めて頂き驚いております。コピーして使わせていただきます。ありがとうございました。

通報する
お礼日時：2013/05/04 23:04

No.3

  • 回答者： Nouble
  • 回答日時：

取りあえず今から検討に入りますが


先に1つ

取りあえずは、まあ、要点としては
「整理整頓すれば見えるものが見えてくる」ですね。


１、
プライベートサブや、ファンクションや、クラスなどで
似たようなことは、引数を渡すだけのサブルーティン化を試みましょう。

どんなに簡単なものについても、これを行えるか検討しましょう。

２、
メモ書きのできるデバイス(紙など)に表して、
計算結果の因果関係など、依存関係を整理しましょう。

３、
サブルーティン呼び出しの羅列、依存関係の整理、を　終えられていれば、
引数のレパートリーや出現パターンが見えてきますから、

出現順など、
調整できるものは調整して、
できるだけ平滑なものにしましょう。
(平滑：適切な言葉が浮かばない　汗)

また、この時
依存関係次第ですが、
同値、同意の引数出現回数が
出来るだけ変化しないようにも
検討してみましょう

４、
引数を分類し、各々をセットに纏め、
構造体変数、クラス、配列変数などで
パックすることを目指しましょう。

５、
引数の出現順パターンが押さえられ、収納できたなら
順に読み出す事を前提とした、ループに纏め
処理を行えるようにしましょう。

ここまで出来たらかなり短くなる可能性があります。


なお、
データセットの収納、引き渡しは
ものによっては
ａｒｒａｙ構文、
dictionary構文、
などを使うと、かなり明示的になりそうですよ？

また、
クラスを使って実行中の外部ファイル組込み(インクルード)を
行う手もあるでしょうね。
(できる… よね？ 確か　確証無い…　けど)


因みに、
私のプライベート ルールでは、賛否も分かれるでしょうが
「複数行ＩＦ構文のThenは、折り返して前に持ってくる」
「登校時は半角スペース２つを全角１つに変えておく」
「程良きところで折り返す」
「const等で意味に対する数値の紐付け、グループ付け、を行って
　可読性、区別性を　担保する」
「日本語で可読性(見える化)を高める」
などをすれば、もっと良い
と、感じました。

まあ、要点としては
「整理整頓すれば見えるものが見えてくる」ですね。


取りあえず見てみますので、当てにせずお待ちを


P・s・
何だか上から目線口調になってしまいましたが、ご容赦下さい。
本意ではありません。
    • good
    • 0
    • 件
通報する
この回答へのお礼

VBAマクロをやり始めたばかりなので、できる所の継ぎ接ぎしかできませんでした。教えていただけることがうれしいです。

通報する
お礼日時：2013/05/04 20:17

No.2

  • 回答者： hallo-2007
  • 回答日時：

とりあえず気が付いたところです。


'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i

If i = 5 Then
MsgBox ("?")
End
End If

これは、Range("B23")の値が　シート　sh1のＡ列ある。
その行が５行目以上の場合の行番号が知りたいということですよね。

Set res = Worksheets("Sh1").Columns("A:A").Find(what:=testno, LookIn:=xlValues, lookat:=xlPart)
if res Is Nothing Then msgbox "ありませんでした"
if res.Row<5 Then msgbox "ありましたが５行目より上"

といった具合に、検索の機能を使って組みなおしてください。
とりあえず、これでだいぶ短くなると思いますし、動作も早くなるはず。

出来たら、そのコードをアップしてください。
たぶん、
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
も
weight(13) = Application.WorksheetFunction.Max(Range("B" & i & ":G" & i)
とかで済みそうですね。

この回答への補足

説明不足でした、sheet1の5行目以下から検索するのIf i = 5 Then　です。sheet1とsheet2から同一番号のデータを読込み、sheet2からは数値のmax,minを抜き出す処理をしています。sheet3に合算するマクロを組んだのですが、loop処理などの方法を知らずcopyで羅列してしまいました。

補足日時：2013/05/04 20:09
通報する
    • good
    • 0
    • 件
通報する
この回答へのお礼

VBAマクロをやり始めたばかりなので、できる所の継ぎ接ぎしかできませんでした。教えていただけることがうれしいです。

通報する
お礼日時：2013/05/04 20:53

No.1

  • 回答者： JazzCorp
  • 回答日時：

'Option Explicit


Sub 記入()
End Sub

アトはEXCELを手に入れてからよ～くッ、考え直す、、、
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。excel VBAに慣れていませんので、改めて勉強してみます。

通報する
お礼日時：2013/05/04 17:47

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報