Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

115 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【80182】Re:文字数が2以上のセルを左上揃え、2未...

困り人 - 18/10/13(土) 15:43 -


	引用なし

	パスワード

▼γ さん：
For Each ...Nextを使ったらできた気がします。
ありがとうございます。
結構時間がかかってしまうのは仕方がないですかね？

Sub Macro1()
Dim c As Range
　　For Each c In Selection
　　　　If Len(c) > 1 Then
　　　　　　With c
　　　　　　　　.HorizontalAlignment = xlLeft
　　　　　　　　.VerticalAlignment = xlTop
　　　　　　　　.WrapText = False
　　　　　　　　.Orientation = 0
　　　　　　　　.AddIndent = False
　　　　　　　　.IndentLevel = 0
　　　　　　　　.ShrinkToFit = False
　　　　　　　　.ReadingOrder = xlContext
　　　　　　　　.MergeCells = False
　　　　　　End With
　　　　
　　　　 Else
　　　　　　With c
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　.WrapText = False
　　　　　　　　.Orientation = 0
　　　　　　　　.AddIndent = False
　　　　　　　　.IndentLevel = 0
　　　　　　　　.ShrinkToFit = False
　　　　　　　　.ReadingOrder = xlContext
　　　　　　　　.MergeCells = False
　　　　　　End With
　　　　 End If
　　Next c
End Sub

>条件付き書式で対応可能ですが、
>あえてマクロなんですね？
>
>詰まっているのはどこですか？
>まず1セルではできますか？
>文字列の長さはLen関数です。
>書式変更はマクロ記録を活用してください。
>
>選択範囲のそれぞれに対して実行するには
>For Each ...Next を使います。

・ツリー全体表示


	【80181】Re:文字数が2以上のセルを左上揃え、2未...

γ - 18/10/13(土) 15:02 -


	引用なし

	パスワード

条件付き書式で対応可能ですが、
あえてマクロなんですね？

詰まっているのはどこですか？
まず1セルではできますか？
文字列の長さはLen関数です。
書式変更はマクロ記録を活用してください。

選択範囲のそれぞれに対して実行するには
For Each ...Next を使います。

・ツリー全体表示


	【80180】文字数が2以上のセルを左上揃え、2未満の...

困り人 - 18/10/13(土) 13:40 -


	引用なし

	パスワード

選択範囲のうち、文字数が2以上のセルを左上揃え、2未満のセルを中央揃えにする
マクロはどう作成すればよいでしょうか？

・ツリー全体表示


	【80179】Re:部課ごとに各項目で集計したい

名木 - 18/10/10(水) 9:59 -


	引用なし

	パスワード

▼マナさん：
>▼名木さん：
>
>>ピボットテーブルでの集計であれば、毎回手入力で
>>出来ますが、まだ先にある道程を考えて、ここは
>>自動化したいと考えたのです。
>
>ピボットテーブルであれば、
>２回めからは、更新ボタンをクリックするだけで
>自動で集計やり直してくれますよ。
>
>マクロ実行ボタンをクリックするのと手間は変わらないのでは？

ピボットの更新でレコード数が増えたりした場合
のデータ範囲の変更も更新されるとは知りませんでした。
自動で範囲を認識しなおすことが出来るのですね。
それであれば、同じことかもしれませんね。

・ツリー全体表示


	【80178】Re:部課ごとに各項目で集計したい

マナ - 18/10/9(火) 18:54 -


	引用なし

	パスワード

▼名木さん：

>ピボットテーブルでの集計であれば、毎回手入力で
>出来ますが、まだ先にある道程を考えて、ここは
>自動化したいと考えたのです。

ピボットテーブルであれば、
２回めからは、更新ボタンをクリックするだけで
自動で集計やり直してくれますよ。

マクロ実行ボタンをクリックするのと手間は変わらないのでは？

・ツリー全体表示


	【80177】Re:部課ごとに各項目で集計したい

名木 - 18/10/9(火) 8:51 -


	引用なし

	パスワード

▼マナさん：
>▼名木さん：
>
>集計シートのレイアウトがわかりません
>どのような結果を期待されていますか
社員部課ごとの所得税以下の項目を
集計させるマクロを考えています。

>提示されたマクロは何か関係ありますか
途中までほかのサイトなどで調べマクロで書いてみましたが、
何が一番シンプルで分かりやすいのか考えているうちに
途方にくれ、質問した次第です。
>
>ピボットテーブルでの集計は検討してみましたか
ピボットテーブルでの集計であれば、毎回手入力で
出来ますが、まだ先にある道程を考えて、ここは
自動化したいと考えたのです。

・ツリー全体表示


	【80176】Re:部課ごとに各項目で集計したい

マナ - 18/10/6(土) 18:40 -


	引用なし

	パスワード

▼名木さん：

集計シートのレイアウトがわかりません
どのような結果を期待されていますか
提示されたマクロは何か関係ありますか

ピボットテーブルでの集計は検討してみましたか

・ツリー全体表示


	【80175】Re:VBA Do Loop Untilでエラー

γ - 18/10/6(土) 17:22 -


	引用なし

	パスワード

内部的な処理の話なので正確なことは不明だが、
再帰処理が関係していると想像。
いわゆる末尾再帰となる書き方(エラーが
でない方の書き方)が推奨されるということでしょう。

・ツリー全体表示


	【80174】部課ごとに各項目で集計したい

名木 - 18/10/6(土) 14:55 -


	引用なし

	パスワード

人事シートをもとに、社員部課別で指定した項目の集計をしたいと
思います。
シンプルで分かりやすいマクロを教えていただけないでしょうか？
結果を示すシートは[集計シート]とします。

Option Explicit

Sub ColCopy()
　　Dim xlBook As Workbook
　　Dim xlSheetOrg As Worksheet
　　Dim xlSheetSel As Worksheet
　　Dim xlSheetDst As Worksheet
　　Dim strDstSheetName As String
　　Dim rngLastRow As Range
　　Dim vntIndex As Variant
　　Dim rngIndexs As Range
　　Dim rngHeader As Range
　　Dim lngColSrc As Long
　　Dim lngColDst As Long
　　Dim rngTargetCol As Range
　　
　　
　　Set xlBook = ThisWorkbook
　　
　　With xlBook
　　　　Set xlSheetSel = .Worksheets("指定")
　　　　Set xlSheetOrg = .Worksheets("人事")
　　End With
　　
　　' コピー先シート名取得
　　strDstSheetName = xlSheetSel.Range("A2").Value
　　
　　' コピー先シートを初期化（なければ生成）
　　On Error GoTo ERR_DST_SHEET
　　Set xlSheetDst = xlBook.Worksheets(strDstSheetName)
　　With xlSheetDst
　　　　.Cells.Clear
　　End With
　　On Error GoTo 0
　　
　　
　　' 項目名を読み取り
　　With xlSheetSel
　　　　Set rngLastRow = .Cells(.Rows.Count, 1).End(xlUp)
　　　　Set rngIndexs = .Range(.Cells(21, 1), rngLastRow)
　　　　Set rngLastRow = Nothing
　　End With
　　
　　' 見出し行の取り込み
　　Set rngHeader = xlSheetOrg.Rows(1)
　　
　　' 該当列のコピー
　　Application.ScreenUpdating = False
　　With xlSheetDst
　　　　lngColDst = 0
　　　　For Each vntIndex In rngIndexs
　　　　　　lngColDst = lngColDst + 1
　　　　　　Set rngTargetCol = rngHeader.Find(CStr(vntIndex))
　　　　　　lngColSrc = rngTargetCol.Column
　　　　　　rngTargetCol.EntireColumn.Copy .Cells(1, lngColDst)
　　　　　　Set rngTargetCol = Nothing
　　　　Next vntIndex
　　　　Set rngIndexs = Nothing
　　End With
　　Application.ScreenUpdating = True
　　
　　GoTo PROC_END
　　
ERR_DST_SHEET:
　　Set xlSheetDst = Sheets.Add(, Sheets("集計"))
　　xlSheetDst.Name = strDstSheetName
　　Resume Next
　　
PROC_END:
　　Set rngHeader = Nothing
　　Set xlSheetDst = Nothing
　　Set xlSheetOrg = Nothing
　　Set xlSheetSel = Nothing
　　Set xlBook = Nothing

End Sub

[人事シート]
　A　　　　　　B　　　　　　　　　C　　　　　　　D　　　　　　　E　　　　　　　　F　　　　G　　　　
1社員氏名　社員部課　　　社員体系平日出勤休日出勤出勤時間残業手当Ａ
2京都　太郎パートフロアーパート　　　　　　　　　　　　　　　　　　　　
3山田　山太　生産　　　　　社員　　　　　　　　　　　　　　　　　　　　
4木本　樹　フロアー　　　　　　社員　　　　　　　　　　　　　　　　　　　　

[指定シート]
　　　　A列
1　　　　集計先
2　　　　集計
3　　　　
4　　　　項目名
5　　　　社員氏名
6　　　　社員部課
7　　　　社員体系
8　　　　支給合計
9　　　　所得税
10　　　　課税通勤手当
11　　　　非課税通勤手当
12　　　　時間外Ａ金額
13　　　　時間外Ｂ金額
14　　　　時間外Ｃ金額
15　　　　時間外Ｄ金額
16　　　　健康保険料(一般)
17　　　　健康保険料(介護)
18　　　　厚生年金保険料
19　　　　雇用保険料
20　　　　住民税
21　　　　控除項目４
22　　　　控除項目５

・ツリー全体表示


	【80173】Re:VBA Do Loop Untilでエラー

γ - 18/10/6(土) 11:44 -


	引用なし

	パスワード

時間がとれたので内容を見てみました。
下記の例で、エラーとなりますね。
そもそもですが、Loop処理の中で再帰呼び出しは不可避なんでしょうか？
何をしようとされているか説明が無いのでよくわかりませんが。

理由は不明ですが、
記法によってエラーが避けられるならそれに従うのがよろしいかと。

Sub test()
　　[H1:H5].Value = Application.Transpose(Array(1, 2, 3, 5, 1)) 'データ設定
　　Call 支(1, False, 1)　　'エラーとならない
End Sub

Sub test2()
　　[H1:H5].Value = Application.Transpose(Array(1, 2, 3, 5, 1))　'データ設定
　　Call 支2(1, False, 1)　 '「式が複雑すぎます」というエラーとなる
End Sub

Function 支(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　Dim myLevel As Byte
　　Dim I_Flag As Boolean

　　With ActiveSheet
　　　　myLevel = Val(.Range("H" & currentRow))
　　　　Do Until myLevel > Val(.Range("H" & currentRow))
　　　　　　
　　　　　　' ここで作業
　　　　　　
　　　　　　currentRow = currentRow + 1
　　　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支(currentRow, I_Flag, 列)
　　　　Loop
　　End With
End Function

Function 支2(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　Dim myLevel As Byte
　　Dim I_Flag As Boolean

　　With ActiveSheet
　　　　myLevel = Val(.Range("H" & currentRow))
　　　　Do
　　　　　　
　　　　　　' ここで作業
　　　　　　
　　　　　　currentRow = currentRow + 1
　　　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支2(currentRow, I_Flag, 列)
　　　　Loop Until myLevel > Val(.Range("H" & currentRow))
　　End With
End Function

・ツリー全体表示


	【80172】Re:ソルバーにてエラー”1004”が出て困...

γ - 18/10/5(金) 7:03 -


	引用なし

	パスワード

最後の部分は私の勘違いでした。取り消します。

再現できる情報が無いので、私には不明です。
他の方の回答をお待ちください。

・ツリー全体表示


	【80171】Re:VBA Do Loop Untilでエラー

γ - 18/10/4(木) 19:23 -


	引用なし

	パスワード

スマフォで見ているので詳細わかりませんが
エラー時の関連する変数の値を教えてください。

・ツリー全体表示


	【80170】Re:ソルバーにてエラー”1004”が出て困...

γ - 18/10/4(木) 19:15 -


	引用なし

	パスワード

悪いけど意味が理解できません。
何回もSolveを実行しているけど、
それらの条件は重なっていくのではなく
独立ですよ。
そして各単位では変数が多い割に
条件が少ないので、
いわゆる不定になっていると思われる。

・ツリー全体表示


	【80169】Re:VBA Do Loop Untilでエラー

まよい人 - 18/10/4(木) 15:54 -


	引用なし

	パスワード

γ 様

ありがとうございます。
仰る通りです。

エラーが生じるコードは

Function 支(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　With ActiveSheet
　　Dim myLevel As Byte
　　myLevel = Val(.Range("H" & currentRow))
　　Do
　　　　Dim I_Flag As Boolean
　　　　I_Flag = CStr(.Range("Q" & currentRow)) = "380"
　　　　If Not I_Flag Then
　　　　　　If flag Then
　　　　　　　　Set ss = Me.Range("E3:E453").Find(Left(.Range("F" & currentRow), 13), LookIn:=xlValues, LookAt:=xlPart)
　　　　　　　　If ss Is Nothing Then Set ss = Me.Range("E3:E453").Find(Left(.Range("F" & currentRow), 11) & "X" & Mid(.Range("F" & currentRow), 13, 1))
　　　　　　　　I_Flag = ss Is Nothing
　　　　　　　　If Not I_Flag Then I_Flag = Me.Cells(ss.Row, 列) = ""

　　　　　　　　If Not I_Flag Then
　　　　　　　　　　If Left(.Range("K" & currentRow), 1) <> "ﾑ" Then
　　　　　　　　　　　　.Range("K" & currentRow) = "ﾑ←" & .Range("K" & currentRow)
　　　　　　　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　　　　　　　End If
　　　　　　　　ElseIf Left(.Range("K" & currentRow), 2) <> "ｼﾞ" Then
　　　　　　　　　　.Range("K" & currentRow) = "ｼﾞ←" & .Range("K" & currentRow)
　　　　　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　　　　　End If
　　　　　　End If
　　　　ElseIf Left(.Range("K" & currentRow), 2) <> "ｼﾞ" Then
　　　　　　.Range("K" & currentRow) = "ｼﾞ←" & .Range("K" & currentRow)
　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　End If
　　　　currentRow = currentRow + 1

　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支(currentRow, I_Flag, 列)
　　Loop Until myLevel > Val(.Range("H" & currentRow))
　　End With
End Function

です。

・ツリー全体表示


	【80168】Re:ソルバーにてエラー”1004”が出て困...

初心者 - 18/10/4(木) 8:23 -


	引用なし

	パスワード

▼γ さん：
すみません、説明不足でした。
画像変換ソフトを用いて、エクセルにデータ化したのをエクセルにてセル数：20×100以上の画像処理を行う過程でそれぞれの平均と偏差を求め、そこからそれぞれの平均と偏差の平均を求めます。
次に2つの画像が同じ対象物を写しているのですが異なる画像の為、それぞれ赤色抽出のデータ値が違います。
そこで、求めた2つの画像の平均と偏差の平均をそれぞれ指定値にして2つの画像データの最適値を出し2つの画像の濃度を均一にするためにソルバーを用います。（目的セルは求めた1ブロックの平均or偏差のセル、変更セルはそれぞれの画像の1ブロックごとにしています。）
尚、1つの画像データが20×100以上で大きくソルバーが使えないため、平均と偏差を求めるところから10×20（データ数200）の１ブロックずつに分けて求めています。
また、制約条件は設定しておりません。

プログラム内のセルや指定値を変えたり、プログラムを増減したりすれば他のデータでも使えるようになっているつもりです。

>　　SolverOk SetCell:="$A$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
>　　　　"$A$1:$T$10", Engine:=1, EngineDesc:="GRG Nonlinear"
>　　SolverOk SetCell:="$B$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
>　　　　"$A$51:$T$60", Engine:=1, EngineDesc:="GRG Nonlinear"
>　　SolverSolve

・ツリー全体表示


	【80167】Re:ソルバーにてエラー”1004”が出て困...

γ - 18/10/3(水) 21:04 -


	引用なし

	パスワード

最初の3行に限定してで結構なので、ソルバーの内容を説明してください。
制約条件とか、何を求めようとしているのか、ということです。
そうした説明がまずもって必要ではないですか？

　　SolverOk SetCell:="$A$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
　　　　"$A$1:$T$10", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$B$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
　　　　"$A$51:$T$60", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve

・ツリー全体表示


	【80166】Re:SAP汎用モジュールのEXPORTパラメータ...

吉田 - 18/10/3(水) 16:40 -


	引用なし

	パスワード

Rows.Add
行番号を指定して、値を入れる

Set oFunction = oRFC.Add("BAPI_USER_ACTGROUPS_ASSIGN")

' Functionにパラメータを渡す
' -- パラメータ名
oFunction.exports("USERNAME") = Cells(11 , user_column)

　' パラメータの代入
　 oFunction.tables("ACTIVITYGROUPS").Rows.Add
　 oFunction.tables("ACTIVITYGROUPS").Value(1, "AGR_NAME") = Cells(11 , role_01_column)

　If IsEmpty(Cells(11 , role_02_column)) = False Then
　　' パラメータの代入
　 oFunction.tables("ACTIVITYGROUPS").Rows.Add
　 oFunction.tables("ACTIVITYGROUPS").Value(2, "AGR_NAME") = Cells(11 , role_02_column)
　End If

oFunction.Call

・ツリー全体表示


	【80165】ソルバーにてエラー”1004”が出て困って...

初心者 - 18/10/3(水) 15:42 -


	引用なし

	パスワード

初めての投稿です。

マクロの記録にてソルバーを記録させ、他のデータに使えるように以下のように編集したところエラーコード"1004"が出てきてしまいソルバーを実行することができません。

尚、デバッグを押したところSolverSolveが黄色くマーキングされ、そこを削除しても次のSolverSolveがマーキングされる現状です。

ネットで対処法を検索し、マクロのツールから参照設定内のSolverにチェックを入れても“1004”が出てきてしまって、実行できません。

無知の初心者なもので解決策が見出せません。
申し訳ございませんが、皆さんご教授お願いします。

------以下、プログラムです。-------
Sub ソルバー2()
'
' ソルバー2 Macro

　
'1-1
'

　　SolverOk SetCell:="$A$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
　　　　"$A$1:$T$10", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$B$102", MaxMinVal:=3, ValueOf:=93.6925, ByChange:= _
　　　　"$A$51:$T$60", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve
　　SolverOk SetCell:="$A$103", MaxMinVal:=3, ValueOf:=24.61834, ByChange:= _
　　　　"$A$1:$T$10", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$B$103", MaxMinVal:=3, ValueOf:=24.6834, ByChange:= _
　　　　"$A$51:$T$60", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve
'1-2

　　SolverOk SetCell:="$A$105", MaxMinVal:=3, ValueOf:=101.8, ByChange:= _
　　　　"$A$11:$T$20", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$B$105", MaxMinVal:=3, ValueOf:=101.8, ByChange:= _
　　　　"$A$61:$T$70", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve
　　SolverOk SetCell:="$A$106", MaxMinVal:=3, ValueOf:=26.23977, ByChange:= _
　　　　"$A$11:$T$20", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$B$106", MaxMinVal:=3, ValueOf:=26.23977, ByChange:= _
　　　　"$A$61:$T$70", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve
　　　　　　　　　
　　　　　　　　・
　　　　　　　　・
　　　　　　　中略
　　　　　　　　・
　　　　　　　　・

'4-3

　　SolverOk SetCell:="$BI$108", MaxMinVal:=3, ValueOf:=119.4167, ByChange:= _
　　　　"$BI$21:$CB$30", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$BJ$108", MaxMinVal:=3, ValueOf:=119.4167, ByChange:= _
　　　　"$BI$71:$CB$80", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverSolve
　　SolverOk SetCell:="$BI$109", MaxMinVal:=3, ValueOf:=3.021422, ByChange:= _
　　　　"$BI$21:$CB$30", Engine:=1, EngineDesc:="GRG Nonlinear"
　　SolverOk SetCell:="$BJ$109", MaxMinVal:=3, ValueOf:=3.021422, ByChange:= _
　　　　"$BI$71:$CB$80", Engine:=1, EngineDesc:="GRG Nonlinear"
　 SolverSolve

End Sub

・ツリー全体表示


	【80164】Re:VBA Do Loop Untilでエラー

γ - 18/10/2(火) 20:55 -


	引用なし

	パスワード

再現するワンセットのコードを提示してはどうですか？
なにかしらエラーが関係しているのに、
具体性が無いと解決は難しいですよ。

・ツリー全体表示


	【80163】VBA Do Loop Untilでエラー

まよい人 - 18/10/2(火) 15:16 -


	引用なし

	パスワード

Do
Loop Until 判定式
とすると
Loop Until 判定式　で、On Error GoToに飛びます。

一方、Until 判定式　を
Do Until 判定式
Loop
とDoの後に移動すると問題なく実行できます。

Loop Until 判定式　のところでブレークをかけ、
ウォッチ式で判定式の値を確認してみると（意図したとおりの）falseです。

なぜ、Doの後ではOKでLoopの後だとエラーになるのでしょうか？

尚、SubからFunctionをCallしており、Do LoopはFunctionに
On Error GoToはSubにあります。

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

115 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free