Excel VBA質問箱 IV

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

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


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

53 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81423】Re:間違いを色であらわすことはできます...

［名前なし］ - 20/7/28(火) 12:38 -


	引用なし

	パスワード

▼γ さん：
>両者の不一致文字列を赤く着色するのではまずいですか？
>山梨市　　山梨　　→　左の市だけを赤くする。

それでも大丈夫です。

・ツリー全体表示


	【81422】Re:間違いを色であらわすことはできます...

γ - 20/7/27(月) 6:06 -


	引用なし

	パスワード

最長共通部分列（longest common subsequence)問題という
比較的良く知られた問題らしいです。
（文章の差異を表示するDiffコマンドというものも同じアルゴリズムの系列です。）

大昔、こちらの掲示板に投稿したものの一部を修正（表示の一部を削除）したものです。
参考にしてください。

Sheet1のA列とB列を比較した結果を、
Sheet2のA列とB列に表示します。（不一致箇所を赤文字かつアンダーラインで表示）

Option Explicit

Dim lcs() As Long
Dim dic1 As Object
Dim dic2 As Object
Dim s1 As String
Dim s2 As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Sub main()
　　Dim k As Long

　　Set ws1 = Worksheets("Sheet1")
　　Set ws2 = Worksheets("Sheet2")

　　'書き込み先のシートをクリアー
　　ws2.UsedRange.Clear

　　'A列とB列の差異を調べて結果をSheet2に表示する
　　For k = 1 To ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row
　　　　diff ws1.Cells(k, 1), ws1.Cells(k, 2)
　　Next
End Sub

Sub diff(r1 As Range, r2 As Range)
　　Dim ar1, ar2
　　Dim v
　　Dim pos As Long
　　Dim kk As Long

　　Set dic1 = CreateObject("Scripting.Dictionary")
　　Set dic2 = CreateObject("Scripting.Dictionary")

　　' 二つの文字列のLCSの長さを求める
　　get_lcs r1, r2

　　'それに対応する最長共通部分列を求める
　　get_lcs_string r1.Value, r2.Value

　　'結果をSheet2に書き込む
　　pos = Application.Max(ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row, _
　　　　　　　　　　　　　ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row) _
　　　　　　　　　　　　　+ 1
　　ws2.Cells(pos, 1) = s1
　　ws2.Cells(pos, 2) = s2

　　'最長共通部分列に該当しない文字列に、書式を設定（赤、アンダーライン）
　　setColor ws2.Cells(pos, 1), ws2.Cells(pos, 2)
End Sub

Function get_lcs(r1 As Range, r2 As Range)
　　Dim j As Long, k As Long

　　s1 = r1.Value
　　s2 = r2.Value
　　' lcs(j,k) は s1の1からjまでの部分列と
　　'　　　　　　 s2の1からkまでの部分列との
　　'　　　　　　 LCSの長さを示す
　　ReDim lcs(0 To Len(s1), 0 To Len(s2))
　　For j = 1 To Len(s1)
　　　　For k = 1 To Len(s2)
　　　　　　If Mid(s1, j, 1) = Mid(s2, k, 1) Then
　　　　　　　　lcs(j, k) = lcs(j - 1, k - 1) + 1
　　　　　　Else
　　　　　　　　lcs(j, k) = WorksheetFunction.Max(lcs(j, k - 1), lcs(j - 1, k))
　　　　　　End If
　　　　Next
　　Next
End Function

Function get_lcs_string(s1 As String, s2 As String)
　　get_lcs_string_sub Len(s1), Len(s2)
End Function

Function get_lcs_string_sub(j As Long, k As Long)
　　If j = 0 Or k = 0 Then Exit Function
　　If Mid(s1, j, 1) = Mid(s2, k, 1) Then
　　　　Call get_lcs_string_sub(j - 1, k - 1)
　　　　dic1(j) = Empty　　 's1 の j番目の文字がLCSを構成
　　　　dic2(k) = Empty　　 's2 の k番目の文字がLCSを構成
　　Else
　　　　If lcs(j - 1, k) >= lcs(j, k - 1) Then
　　　　　　Call get_lcs_string_sub(j - 1, k)
　　　　Else
　　　　　　Call get_lcs_string_sub(j, k - 1)
　　　　End If
　　End If
End Function

Function get_partition(s As String, d As Object) As Variant
　　Dim key

　　For Each key In d.keys
　　　　Mid$(s, key, 1) = "_"　 ' 余り使用されない文字の意
　　Next
　　get_partition = Split(s, "_")
End Function

Function setColor(r1 As Range, r2 As Range)
　　Dim j As Long, k As Long

　　'背景色を水色
　　r1.Interior.ColorIndex = 34
　　r2.Interior.ColorIndex = 34

　　'マッチしない文字列の文字色を赤に
　　For j = 1 To Len(r1.Value)
　　　　If Not dic1.exists(j) Then
　　　　　　With r1.Characters(Start:=j, Length:=1).Font
　　　　　　　　.Underline = xlUnderlineStyleSingle
　　　　　　　　.ColorIndex = 3
　　　　　　End With
　　　　End If
　　Next

　　For k = 1 To Len(r2.Value)
　　　　If Not dic2.exists(k) Then
　　　　　　With r2.Characters(Start:=k, Length:=1).Font
　　　　　　　　.Underline = xlUnderlineStyleSingle
　　　　　　　　.ColorIndex = 3
　　　　　　End With
　　　　End If
　　Next
End Function

・ツリー全体表示


	【81421】Re:表を加工して別ｼｰﾄに転記したい

ありす - 20/7/27(月) 0:15 -


	引用なし

	パスワード

▼マナさん：
ありがとうございました。
前述の修正と以下に頂いたものを確認しながら、勉強してみます。
品名の後ろの年月、すっかり忘れてました笑
これ重要だったのに。
ソートの部分も、ごちゃごちゃ書かずにすっきりできたので、
変数の部分と合わせて確認しながら書いてみます。

>▼ありすさん：
>
>こんな書き方もできます
>マクロで、Noを作成し、最後に削除しています。
>
>>・最後に並べ替えをする際に、コードが被る事があるので、C列に並べ替え用Noを入れる項目を追加。
>

>
>Option Explicit
>
>Sub test()
>　　Dim wsF As Worksheet, wsT As Worksheet
>　　Dim 期間 As Long, 開始日 As Date
>　　Dim 元データ As Range, データ数 As Long
>　　Dim 貼付先 As Range
>　　Dim k As Long, 月末 As Date
>　　Dim 商品名 As Range, 数式 As String
>　　Dim ソート範囲 As Range
>
>　　Set wsF = Worksheets("Sheet1")
>　　Set wsT = Worksheets("Sheet2")　'転記先
>　　
>　　期間 = wsF.Range("B5").Value
>　　開始日 = wsF.Range("B6").Value
>　　
>　　Set 元データ = wsF.Range("C6", wsF.Range("K" & Rows.Count).End(xlUp))
>　　元データ.Columns(1).Formula = "=row()"　　'並べ替え用No
>　　データ数 = 元データ.Rows.Count
>　　
>　　Set 貼付先 = wsT.Range("C6")
>　　　
>　　For k = 1 To 期間
>'　　'sheet1のデータをsheet2に貼り付け
>　　　　元データ.Copy
>　　　　貼付先.PasteSpecial xlPasteValues
>
>　　　　'日付の入力
>　　　　月末 = DateSerial(Year(開始日), Month(開始日) + k, 0)
>　　　　貼付先.Resize(データ数).Columns(2).Value = 月末
>　　　　
>　　　　'商品名に日付を付加
>　　　　Set 商品名 = 貼付先.Resize(データ数).Columns(7)
>　　　　数式 = 商品名.Address & "&""" & Format(月末, "（'yy/m月分）") & """"
>　　　　商品名.Value = 商品名.Worksheet.Evaluate(数式)
>　　　　
>　　　　Set 貼付先 = 貼付先.Offset(データ数)
>　　Next
>　　
>　　'並べ替え
>　　Set ソート範囲 = wsT.Range("C6", wsT.Range("K" & Rows.Count).End(xlUp))
>　　ソート範囲.Sort ソート範囲.Columns(1)
>　　
>　　'並べ替え用Noの削除
>　　ソート範囲.Columns(1).ClearContents
>　　元データ.Columns(1).ClearContents
>　　　　
>End Sub
>
>
>

・ツリー全体表示


	【81420】Re:間違いを色であらわすことはできます...

γ - 20/7/26(日) 23:44 -


	引用なし

	パスワード

両者の不一致文字列を赤く着色するのではまずいですか？
山梨市　　山梨　　→　左の市だけを赤くする。

・ツリー全体表示


	【81419】間違いを色であらわすことはできますでし...

moro - 20/7/26(日) 17:52 -


	引用なし

	パスワード

こんにちは。質問ですが、
間違いを色で表すことはできますでしょうか？

Ａ列が正しく、Ｂ列が間違っているおり、Ｂ列の間違い
を表すもので、例えば、

Ａ列　　　　Ｂ列
山田　　　　山中　　　→　山中←”中”を赤色にする
田中　　　　田仲　　　→　田仲←”仲”を赤色にする
ゆうじ　　　ようじ　　→　ようじ←”よ”を赤色にする
山梨市　　　山梨　　　→　山梨←”市”を付け加えて赤色にする
間違い探し　町外探し　→　町外探し←”町外”を赤色にする

文字数が同じであったり、多かったりする分にはできないことは
ないのですが、少ない分に関してが難しく、何か良い知恵が
ありましたらよろしくお願いします。

・ツリー全体表示


	【81418】Re:表を加工して別ｼｰﾄに転記したい

マナ - 20/7/26(日) 17:40 -


	引用なし

	パスワード

▼ありすさん：

こんな書き方もできます
マクロで、Noを作成し、最後に削除しています。

>・最後に並べ替えをする際に、コードが被る事があるので、C列に並べ替え用Noを入れる項目を追加。

Option Explicit

Sub test()
　　Dim wsF As Worksheet, wsT As Worksheet
　　Dim 期間 As Long, 開始日 As Date
　　Dim 元データ As Range, データ数 As Long
　　Dim 貼付先 As Range
　　Dim k As Long, 月末 As Date
　　Dim 商品名 As Range, 数式 As String
　　Dim ソート範囲 As Range

　　Set wsF = Worksheets("Sheet1")
　　Set wsT = Worksheets("Sheet2")　'転記先
　　
　　期間 = wsF.Range("B5").Value
　　開始日 = wsF.Range("B6").Value
　　
　　Set 元データ = wsF.Range("C6", wsF.Range("K" & Rows.Count).End(xlUp))
　　元データ.Columns(1).Formula = "=row()"　　'並べ替え用No
　　データ数 = 元データ.Rows.Count
　　
　　Set 貼付先 = wsT.Range("C6")
　　　
　　For k = 1 To 期間
'　　'sheet1のデータをsheet2に貼り付け
　　　　元データ.Copy
　　　　貼付先.PasteSpecial xlPasteValues

　　　　'日付の入力
　　　　月末 = DateSerial(Year(開始日), Month(開始日) + k, 0)
　　　　貼付先.Resize(データ数).Columns(2).Value = 月末
　　　　
　　　　'商品名に日付を付加
　　　　Set 商品名 = 貼付先.Resize(データ数).Columns(7)
　　　　数式 = 商品名.Address & "&""" & Format(月末, "（'yy/m月分）") & """"
　　　　商品名.Value = 商品名.Worksheet.Evaluate(数式)
　　　　
　　　　Set 貼付先 = 貼付先.Offset(データ数)
　　Next
　　
　　'並べ替え
　　Set ソート範囲 = wsT.Range("C6", wsT.Range("K" & Rows.Count).End(xlUp))
　　ソート範囲.Sort ソート範囲.Columns(1)
　　
　　'並べ替え用Noの削除
　　ソート範囲.Columns(1).ClearContents
　　元データ.Columns(1).ClearContents
　　　　
End Sub

　

・ツリー全体表示


	【81417】Re:表を加工して別ｼｰﾄに転記したい

マナ - 20/7/26(日) 13:10 -


	引用なし

	パスワード

▼ありすさん：

修正してみました。

>　なぜか、データの項目名から取ってきてしまう場合が5回に1回くらい起こって>しまった。→未解決

>Sheet1.Range("C6:K" & Cells(Rows.Count, "E").End(xlUp).Row).Copy

Cells(Rows.Count, "E")の前にも、シート指定が必要です。

Sub tenki2()
　　Dim k As Long, g As Long 'k=期間　g=繰り返し用
　　Dim MaxRow1 As Long, MaxRow2 As Long
　　Dim kaishi As Date '開始日
　　Dim shuryo As Date '終了日
　　Dim h As Date '日付入力用
　　
　　'変数"k"に期間(何か月)をセット
　　k = Sheet1.Range("B5")
　　kaishi = Sheet1.Range("B6")
　　
　　For g = 1 To k
　　'sheet1のデータをsheet2に貼り付け
　　If Sheet2.Range("C6") = "" Then
　　　　MaxRow1 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　Sheet1.Range("C6:K" & Sheet1.Cells(Rows.Count, "E").End(xlUp).Row).Copy
　　　　Sheet2.Range("C6").PasteSpecial
　　　　MaxRow2 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row
　　Else
　　　 MaxRow1 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　Sheet1.Range("C6:K" & Sheet1.Cells(Rows.Count, "E").End(xlUp).Row).Copy
　　　　Sheet2.Range("C" & MaxRow1).PasteSpecial
　　　　MaxRow2 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row
　　End If
　　'日付の入力
　　h = DateSerial(Year(kaishi), Month(kaishi) + g, 0)
　　Sheet2.Range("D" & MaxRow1 & ":D" & MaxRow2).Value = h
　　Next
　　'並べ替え
　　With Sheet2.Sort
　　　　.SortFields.Clear
　　　　.SortFields.Add Key:=Sheet2.Range("C6")
　　　　.SortFields.Add Key:=Sheet2.Range("D6")
　　　　.SetRange Sheet2.Range("C5:K" & MaxRow2)
　　　　.Header = xlYes
　　　　.Apply
　　End With
　　
End Sub

・ツリー全体表示


	【81416】Re:表を加工して別ｼｰﾄに転記したい

ありす - 20/7/25(土) 23:47 -


	引用なし

	パスワード

▼マナさん：
▼マナさん
ご教示頂いた順序でマクロを書いてみました。
・最後に並べ替えをする際に、コードが被る事があるので、C列に並べ替え用Noを入れる項目を追加。
・並べ替えの書き方がわからなかったので、記録して範囲を最終行までに変更。
　→省けるコードなどがわからなかったので、そのままコピペしてしまった。
　もっとシンプルに書く方法などがありますか？
・データの量を増やして何度かテストしたのですが、
　なぜか、データの項目名から取ってきてしまう場合が5回に1回くらい起こってしまった。→未解決

書いたコードは以下の通りです。
添削とアドバイスがありましたらご教示頂きたく、よろしくお願いします。

Sub tenki()
Dim k As Long, g As Long 'k=期間　g=繰り返し用
Dim MaxRow1 As Long
Dim kaishi As Date '開始日
Dim shuryo As Date '終了日
Dim h As Date '日付入力用

'変数"k"に期間(何か月)をセット
k = Sheet1.Range("B5")
kaishi = Sheet1.Range("B6")
shuryo = Sheet1.Range("B7")

For g = 1 To k
　　'sheet1のデータをsheet2に貼り付け
　　If Sheet2.Range("C6") = "" Then
　　　　MaxRow1 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　Sheet1.Range("C6:K" & Cells(Rows.Count, "E").End(xlUp).Row).Copy
　　　　Sheet2.Range("C6").PasteSpecial
　　　　MaxRow2 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row
　　Else
　　　　MaxRow1 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　Sheet1.Range("C6:K" & Cells(Rows.Count, "E").End(xlUp).Row).Copy
　　　　Sheet2.Range("C" & MaxRow1 & "").PasteSpecial
　　　　MaxRow2 = Sheet2.Cells(Rows.Count, "C").End(xlUp).Row
　　End If
　　'日付の入力
　　h = DateSerial(Year(kaishi), Month(kaishi) + g, 0)
　　Sheet2.Range("D" & MaxRow1 & ":D" & MaxRow2 & "").Formula = h
Next
'並べ替え
　　ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("C6:C" & MaxRow2 & "") _
　　　　, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("D6:D" & MaxRow2 & "") _
　　　　, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　With ActiveWorkbook.Worksheets("Sheet2").Sort
　　　　.SetRange Range("C5:K" & MaxRow2 & "")
　　　　.Header = xlYes
　　　　.MatchCase = False
　　　　.Orientation = xlTopToBottom
　　　　.SortMethod = xlPinYin
　　　　.Apply
　　End With
End Sub

・ツリー全体表示


	【81415】Re:表の比較

マナ - 20/7/24(金) 11:51 -


	引用なし

	パスワード

▼T-K さん：

dicYは、使う必要ありませんでした。

・ツリー全体表示


	【81414】Re:複数の値からある合計に一致するすべ...

マナ - 20/7/24(金) 11:24 -


	引用なし

	パスワード

▼ゆきぼさん：

>こちらのサイトは私も参考にして試してみたのですが
>動かないか、思うような答えが出ないかのどちらかでした。
>

わたしが試したのは、最後の回答者のコードだけですが
期待通りの結果になりましたが…

・ツリー全体表示


	【81413】Re:複数の値からある合計に一致するすべ...

ゆきぼ - 20/7/24(金) 11:03 -


	引用なし

	パスワード

▼マナさん：
>▼ゆきぼさん：
>
>検索してみました。
>ht　tps://teratail.com/questions/65795

マナ様
ご回答いただきありがとうございました。
こちらのサイトは私も参考にして試してみたのですが
動かないか、思うような答えが出ないかのどちらかでした。

お時間を取らせてしまい申し訳ありませんでした。

・ツリー全体表示


	【81412】Re:表の比較

マナ - 20/7/24(金) 11:03 -


	引用なし

	パスワード

▼T-K さん：

>最後にデータをエクセルシートに処理する際に
>繰り返し処理にて展開してますが一括での感じがわかりません

それだと、速度改善にならないと思います。
dictionaryでも、一括で書き込まないと同じです。

Sub test2()
　　Dim fSh As Worksheet
　　Dim tSh As Worksheet
　　Dim dicX As Object
　　Dim dicY As Object
　　Dim tbl As Range
　　Dim i As Long, k As Long
　　Dim dt As Double
　　Dim com As String
　　Dim mX, mY
　　Dim w
　
　　Application.ScreenUpdating = False
　
　　Set dicX = CreateObject("Scripting.Dictionary")
　　Set dicY = CreateObject("Scripting.Dictionary")

　　Set fSh = Sheets("Sheet1")
　　Set tSh = Sheets("Sheet2")
　
　　fSh.Cells.Interior.ColorIndex = xlNone
　　
　　Set tbl = tSh.Range("A1").CurrentRegion
　　w = tbl.Value
　
　　With fSh.Range("A1").CurrentRegion
　　　　For i = 2 To .Rows.Count
　　　　　　com = .Cells(i, "B").Value
　　　　　　If Not dicY.exists(com) Then
　　　　　　　　mY = Application.Match(com, tbl.Columns("B"), 0)
　　　　　　　　If IsError(mY) Then
　　　　　　　　　　.Rows(i).Interior.ColorIndex = 3
　　　　　　　　End If
　　　　　　　　dicY(com) = mY
　　　　　　End If
　　　　　　
　　　　　　If IsNumeric(dicY(com)) Then
　　　　　　　　For k = 3 To .Columns.Count
　　　　　　　　　　dt = .Cells(1, k).Value2
　　　　　　　　　　If Not dicX.exists(dt) Then
　　　　　　　　　　　　mX = Application.Match(dt, tbl.Rows(1), 0)
　　　　　　　　　　　　If IsError(mX) Then
　　　　　　　　　　　　　　.Columns(k).Interior.ColorIndex = 3
　　　　　　　　　　　　End If
　　　　　　　　　　　　dicX(dt) = mX
　　　　　　　　　　End If
　　　　　　　　　　　　
　　　　　　　　　　If IsNumeric(dicX(dt)) Then
　　　　　　　　　　　　w(dicY(com), dicX(dt)) = .Cells(i, k).Value
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With
　　
　　tbl.Value = w
　
　　MsgBox "転記完了"
　
End Sub

・ツリー全体表示


	【81410】Re:表の比較

T-K - 20/7/23(木) 23:51 -


	引用なし

	パスワード

とりあえず、すべて人任せのところがある為
わからないなりに自分で考えて作ってみました。(下記に載せました)
支離滅裂な感じですが、一応動きました。
データが増えた場合この処理ではどうなのかわからないですが・・・
最後にデータをエクセルシートに処理する際に
繰り返し処理にて展開してますが一括での感じがわかりません
やはりDictinaryのほうがシンプルに処理できそうなのでことらを
これからも使用します。今回はアドバイスいただきありがとうございました。

Sub 展開()

Dim myval0(), myval, myval1(), myval2(), myval3() 'データ入力用配列の宣言
Dim Myoutpt, Myoutpt1(), Myoutpt2(), Myoutpt0(), Myoutpt3() '出力用配列の宣言
Dim msg

Dim 品番1 As Range
Dim 品番2 As Range

'--------------------------------------------------------

Dim sh1 As Worksheet　'シート宣言

Dim sh As Worksheet

'-----------------------------------変数(Long型作成)　宣言

Dim a As Long
Dim b As Long
Dim d As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim n As Long

'---------------------------------------

Application.ScreenUpdating = False '画面停止処理

Set sh = Worksheets("データ取り込み")　'Sh＝データ取り込みシート

Set sh1 = Worksheets("集計")　'　Sh1=集計シート

'入力用配列の作成------------------------------------------------------------

myval = sh.Range("A1").CurrentRegion.Value 'データ取り込みシートのデータを配列に格納する
ReDim myval1(2 To UBound(myval, 1)) '配列要素数を設定する
For i = 2 To UBound(myval, 1)

myval1(i) = myval(i, 1) & myval(i, 2) '品番データを配列に格納する

Next

ReDim myval2(3 To (UBound(myval, 2) - 4)) '配列要素数を設定する

For n = 3 To (UBound(myval, 2) - 4) '納期データを配列に格納する
myval2(n) = myval(1, n)

Next

ReDim myval0(2 To UBound(myval, 1), 3 To (UBound(myval, 2) - 4)) '配列要素を設定

For a = 2 To UBound(myval, 1)
For b = 3 To UBound(myval, 2) - 4　'計画数をデータに確保する

myval0(a, b) = myval(a, b)

Next
Next

n = 2
d = 3
ReDim myval3(2 To UBound(myval1, 1), 3 To UBound(myval2, 1))　'配列要素数を設定する

For l = 2 To UBound(myval1, 1)　'すべての情報を配列に格納する
For m = 3 To UBound(myval2, 1)

myval3(l, m) = Split(myval1(l) & "_" & myval2(m) & "_" & myval0(n, d), "_") 'データを区切って連結させる

If d = UBound(myval0, 2) Then
n = n + 1
d = 3
If n = UBound(myval0, 1) Then

Exit For
End If

Else

d = d + 1

End If

Next
Next

'出力用配列作成--------------------------------------------

Myoutpt = sh1.Range("A1").CurrentRegion.Value 'データ取り込みシートのデータを配列に格納する
ReDim Myoutpt1(2 To UBound(Myoutpt, 1)) '配列要素数を設定する
For i = 2 To UBound(Myoutpt, 1)

Myoutpt1(i) = Myoutpt(i, 1) & Myoutpt(i, 2) '品番データを配列に格納する

Next

ReDim Myoutpt2(4 To (UBound(Myoutpt, 2)))　'配列要素数を設定する

For n = 4 To (UBound(Myoutpt, 2))　'納期データを配列に格納する
Myoutpt2(n) = Myoutpt(1, n)

Next

ReDim Myoutpt0(2 To UBound(Myoutpt, 1), 4 To UBound(Myoutpt, 2))　'配列要素を設定

For a = 2 To UBound(Myoutpt, 1)
For b = 4 To UBound(Myoutpt, 2)　'計画数をデータに確保する

Myoutpt0(a, b) = Myoutpt(a, b)

　Next
Next

ReDim Myoutpt3(2 To UBound(Myoutpt1, 1), 4 To UBound(Myoutpt2, 1))　'配列要素数を設定する

For l = 2 To UBound(Myoutpt1, 1)　'すべての情報を配列に格納する
For m = 4 To UBound(Myoutpt2, 1)

Myoutpt3(l, m) = Split(Myoutpt1(l) & "_" & Myoutpt2(m) & "_" & Myoutpt0(l, m), "_") 'データを区切って”＿”で連結させる

　　 Next
Next

For j = LBound(Myoutpt3, 1) To UBound(Myoutpt3, 1)
　　For i = LBound(Myoutpt3, 2) To UBound(Myoutpt3, 2)
　　　For k = LBound(myval3, 1) To UBound(myval3, 1)
　　　　For l = LBound(myval3, 2) To UBound(myval3, 2)
　　　　
　　　　
　　　　If j > UBound(myval3, 1) Then 'データ取り込みの品番に新規があり上限が増えた場合処理しない
　　　　Exit For
　　　　End If

　　If Myoutpt3(j, i)(0) & Myoutpt3(j, i)(1) = myval3(k, l)(0) & myval3(k, l)(1) Then　'品番＆納期の照合をして同じ場合値を取得
　　
　　
　　　　　　　 Myoutpt3(j, i)(2) = myval3(k, l)(2)
　　　　　　　
　　　　　　　
　　　　　　　 Else
　　　　　　　 Myoutpt3(j, i)(2) = Myoutpt3(j, i)(2)　'集計でーたにすでに値があり、今回取り込み対象外の場合集計のセルデータを登録

　　　End If

　　　　　　　　　Next
　　
　　　　　　　Next
　　　　　　　　　　　
　　　　　Next
　　 Next

'-------------------------------------------------------　集計シートに値を出力する

For i = 2 To UBound(Myoutpt3, 1)

　　　sh1.Cells(i, 3).Value = Myoutpt3(i, 4)(0)

Next

　 For i = 4 To UBound(Myoutpt3, 2)
　　　sh1.Cells(1, i).Value2 = Myoutpt3(2, i)(1)

　 Next

For m = LBound(Myoutpt3, 1) To UBound(Myoutpt3, 1)

　　　For n = LBound(Myoutpt3, 2) To UBound(Myoutpt3, 2)

　　　　　　　　 sh1.Cells(m, n) = Myoutpt3(m, n)(2)

　　 Next
Next

'----------------------------------------------------------------------集計シート品番とデータ取り込みシートのデータを照合して違う場合色で表示する

Set 品番1 = sh.Range("A1:A1000")
Set 品番2 = sh1.Range("A1:A1000")
'bも同じようにしてください。

'カウンタが1からセルの個数になるまで繰り返し処理
For i = 1 To 品番1.Cells.Count
　If 品番1.Cells(i).Value <> 品番2.Cells(i).Value Then

品番1.Cells(i).Interior.ColorIndex = 6

　End If
Next i 'この行に来たら「For ～」の行に勝手に戻

'-----------------------------------------------------------------------

Application.ScreenUpdating = True　'画面更新をOKにする

MsgBox "処理終了"

End Sub

・ツリー全体表示


	【81409】Re:複数の値からある合計に一致するすべ...

マナ - 20/7/23(木) 23:46 -


	引用なし

	パスワード

▼ゆきぼさん：

検索してみました。
ht　tps://teratail.com/questions/65795

・ツリー全体表示


	【81408】複数の値からある合計に一致するすべての...

ゆきぼ - 20/7/23(木) 19:00 -


	引用なし

	パスワード

初めまして。
よろしくお願い致します。

＜質問＞
I2～I22にランダムに値（数字）が入力されています。

　　I　　J　　K　　L　　M　　N　　O　　P
2　 1
3　 3
4　 5
5　 9
6　 12
・
・
・
22　35

例えば「I22」は35ですが、I2～I22までの値を足して「35」となる
組み合わせを「J22、K22、L22・・・」に表示させたいです。
かつ、表の上に希望の数字を入れるボックスと開始ボタンを付けたいです。

<EX>
J22 1+3+9+12　K22 3+5+9+・・・　L22 9+12+・・・

上記のようにすべての組み合わせを表示させたいのですが、
ソルバーではできず、自分なりにVBAを組んでみたのですが
初心者ということもあり、どの構文をどのようにして範囲をどこに
設定してよいかなどがわかりませんでした。

また、ボタンにVBAを登録はできるのですが、希望の数字を入力する
ボックスとそこに入力された数字をVBAに反映する方法も調べながら
やっては見たのですがうまく生きんせんでした。

丸投げのような形になってしまい、恐縮なのですがご存知の方が
いらっしゃいましたら、ご教授をお願い致します。

よろしくお願い致します。

・ツリー全体表示


	【81407】Re:表を加工して別ｼｰﾄに転記したい

ありす - 20/7/22(水) 21:45 -


	引用なし

	パスワード

▼マナさん：
並べ替えの件、最後にかいてありました。ごめんなさい。
2重に繰り返す方で途中まで書いてみてましたが、
最後に並べ替える方に方向転換して書いてみます。

>▼ありすさん：
>
>>これだと、私が最終的に作りたい形にはならないですが、
>>最後に並べ替えなどする感じになるでしょうか。
>
>はい。そう書きませんでしたか。
>
>>例はデータも期間も少なくしていましたが、
>>最終的な表は100行を余裕で超えるものになる場合が多いので、最後に並べ替えではなく、
>
>6行でも、1000行でも１回並べ替えるだけです。
>
>
>>１行目のデータを期間分の行にして、2行目に移る方法で考えていました。
>
>それでもよいですが、
>・元データの数だけ繰り返し
>・月数の数だけ繰り返し
>と２重に繰り返すことになって、複雑なマクロになりそうな気がしました。

・ツリー全体表示


	【81406】Re:表を加工して別ｼｰﾄに転記したい

マナ - 20/7/22(水) 21:02 -


	引用なし

	パスワード

▼ありすさん：

>これだと、私が最終的に作りたい形にはならないですが、
>最後に並べ替えなどする感じになるでしょうか。

はい。そう書きませんでしたか。

>例はデータも期間も少なくしていましたが、
>最終的な表は100行を余裕で超えるものになる場合が多いので、最後に並べ替えではなく、

6行でも、1000行でも１回並べ替えるだけです。

>１行目のデータを期間分の行にして、2行目に移る方法で考えていました。

それでもよいですが、
・元データの数だけ繰り返し
・月数の数だけ繰り返し
と２重に繰り返すことになって、複雑なマクロになりそうな気がしました。

・ツリー全体表示


	【81405】Re:表を加工して別ｼｰﾄに転記したい

ありす - 20/7/22(水) 14:52 -


	引用なし

	パスワード

▼マナさん：
これだと、私が最終的に作りたい形にはならないですが、
最後に並べ替えなどする感じになるでしょうか。
例はデータも期間も少なくしていましたが、
最終的な表は100行を余裕で超えるものになる場合が多いので、最後に並べ替えではなく、
１行目のデータを期間分の行にして、2行目に移る方法で考えていました。

そうすると、元データの行数分繰り返す。
sheet1の6行目(ｎ行目にしてデータの数分繰り返し）を貼り付け→ここで期間の月数分の行を作ってしまったほうがいい？
D列に最初の月から最後の月までの月末日を入力
→ここも月数分繰り返して月末日取得、入力
品名の後ろに('yy/mm月分）をくっつける。
→ここがどうしていいか想像がつかないです。
という流かなと思っています。

例で7月から10月としましたが、開始日、終了日はデータによってことなるので、
どうやって月をと月末日をだすのか悩んでました。

一旦、わからないながらにという感じになってしまいますが、
書いてみるので、添削＆アドバイス、引き続きいただけると嬉しいです。

後程、また書き込みします。
よろしくお願いします。

>▼ありすさん：
>
>こんな流れのマクロです
>
>１）sheet1のE6:K7を、sheet2のE6にコピー
>２）sheet2のD6:D7に、"2020/7/31"を入力
>３）sheet2のI6:I7の値に、"('20/7月分)"を付加
>４）sheet1のE6:K7を、sheet2のE8にコピー
>５）sheet2のD8:D9に、"2020/8/31"を入力
>６）sheet2のI8:I9の値に、"('20/8月分)"を付加
>７）sheet1のE6:K7を、sheet2のE10にコピー
>８）sheet2のD10:D11に、"2020/9/30"を入力
>９）sheet2のI10:I11の値に、"('20/9月分)"を付加
>10）G列で並び替え

・ツリー全体表示


	【81404】Re:表を加工して別ｼｰﾄに転記したい

ありす - 20/7/22(水) 14:28 -


	引用なし

	パスワード

マナさん

ありがとうございます！
いただいた流れで、書いてみて、こちらに転記してみます。
今、別の仕事が立て込んでしまって、お返事が遅くなってしまいました。

時間を見て、一度書いてみます。

・ツリー全体表示


	【81403】Re:表を加工して別ｼｰﾄに転記したい

マナ - 20/7/21(火) 21:53 -


	引用なし

	パスワード

▼ありすさん：

こんな流れのマクロです

１）sheet1のE6:K7を、sheet2のE6にコピー
２）sheet2のD6:D7に、"2020/7/31"を入力
３）sheet2のI6:I7の値に、"('20/7月分)"を付加
４）sheet1のE6:K7を、sheet2のE8にコピー
５）sheet2のD8:D9に、"2020/8/31"を入力
６）sheet2のI8:I9の値に、"('20/8月分)"を付加
７）sheet1のE6:K7を、sheet2のE10にコピー
８）sheet2のD10:D11に、"2020/9/30"を入力
９）sheet2のI10:I11の値に、"('20/9月分)"を付加
10）G列で並び替え

・ツリー全体表示


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

53 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free