[[20230307135342]] 『セルの挿入と結合を一気に行い変換したシートを作』(カラス) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『セルの挿入と結合を一気に行い変換したシートを作りたいです』(カラス)

こんにちは。教えて頂きたいです。

M列15行目を起点に、右方向に15行目が空白になるまで
列を2列挿入して結合し、列全体を1行3列のセルに変換をしたものを
ブック内の右隣にシートを出力したいです。

言葉足らずで申し訳ないのですが

行列 M O P R R
15 20 25 45 63 56
16 16 23 84 26 95
17 25 85 58 96 97

だった場合

↓ 
行列     MNO PQR STU VWX YZAA
15 20 25 45 63 56
16 16 23 84 26 95
17 25 85 58 96 97

のようにしてブック内の右のシートに出力させたいです。

列全ての処理というのが厳しいのであれば
M列15行目から下に向かって空白行になるまで2列挿入して結合させ1行3列に
それをM列から右に向かって空白の列まで処理を繰り返していく

というような処理を教えて頂きたいです。
ご迷惑とお手数をおかけしてすみませんが宜しくお願い致します。

< 使用 Excel:Microsoft365、使用 OS:Windows11 >


すみません、コメント追加させてください
15行目が空白列まで、空白行になるまで2列挿入と結合をして1行3列のセルにするのは
列の1行目から処理をさせたいです。
(カラス) 2023/03/07(火) 14:24:11

質問がよくわからないんですが、↓で合ってますか?

 ・M列から右方向に2列ずつ列を挿入する。
 ・15行目から下方向に、空白行まで3列でセル結合する。

 Sub test()
     Dim i As Long, j As Long
     For j = Cells(15, Columns.Count).End(xlToLeft).Column To 13 Step -1
         Columns(j).Resize(, 2).Insert Shift:=xlToRight
         For i = 15 To Cells(Rows.Count, j + 2).End(xlUp).Row
             Cells(i, j + 2).Resize(, 3).Merge
         Next i
     Next j
 End Sub
(フォーキー) 2023/03/07(火) 20:12:52

(フォーキー)様

モジュールをありがとうございました。
取り急ぎ、試させてもらいましたが、希望していたものとは挙動が異なりました。

私に説明する知識と能力が無い為申し訳ありません。

上記のコードを実行すると

・15行目から最終行まで
・元のM列→OPQ列、元のN列→RST、元のO列→UVW列として結合されます。(M,Nは結合も無く空白)

私の希望としましては、15行目が空白だった場合
・1行目から最終行まで、
・元のM列→MNO列 元のN列→PQR列 元のO列→STU列
とM列を起点として結合させて行きたく思っております。

頂いたコードを弄って見ますが、もしよろしければ引き続きお助け頂けると幸いです。
すみませんが宜しくお願い致します。

(カラス) 2023/03/07(火) 22:28:53


申し訳ないですが、希望動作がイメージできないです。
元の表と、結果図をレイアウトで示していただけると助かります。
※レイアウトは他の質問ログを参考にしてください。
※私はしばらくパソコン触れないので、他の回答者をお待ち下さい。
(フォーキー) 2023/03/07(火) 22:41:48

本当に言葉足らずで申し訳ないです。
レイアウトでうまく伝えられるかわかりませんが

現状↓↓↓

            |  [L]  |  [M]  |  [N]  |  [O]  |  [P]  |  [Q]  |  [R]  |  […] 何列になるか     
[1 ]        |       |       |       |       |       |       |       |       毎回違う                   
[2 ]        |       |       |       |       |       |       |       |       

[7 ]     | 項目 | 1 | 2 | 3 | 4 | 5 | 6 |
[8 ]      | 規格 | 15 | 20 | 10 | 33 | 3 | 5 |
[9 ]    | 上限 | 16 | 22 | 11 | 36 | 3.5 | 6 |
[10]     | 下限 | 14 | 18 | 9 | 30 | 2.5 | 4

[11]     | 範囲 | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 |
[12]     | 平均 | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 | ・
[13]     | MAX | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 |
[14]     | MIN | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 |
[15]     | n1 | 15.3 | 21.4 | 11.2 | 35.3 | 3.3 | 4.6 |
[16]     | n2 | 14.9 | 20.8 | 10.1 | 34.2 | 3.1 | 6.3 |
[17]     | n3 | 14.7 | 20.4 | 10.4 | 35.7 | 3.3 | 6.6 |             
           

                 何行になるか毎回違う

このレイアウトを↓↓↓

            |  [L]  | [MMO] | [PQR] | [STU] | [VWX] | [YZAA]|[ABACAD]|  […]      
[1 ]        |       |       |       |       |       |       |        |  最終列まで                      
[2 ]        |       |       |       |       |       |       |        |       

[7 ]    | 項目 | 1 | 2 | 3 | 4 | 5 | 6 |
[8 ]    | 規格 | 15 | 20 | 10 | 33 | 3 | 5 |
[9 ]    | 上限 | 16 | 22 | 11 | 36 | 3.5 | 6 |
[10]    | 下限 | 14 | 18 | 9 | 30 | 2.5 | 4
[11]    | 範囲 | 関数 | 関数 | 関数 | 関数 | 関数 | 関数

[12]    | 平均 | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 | ・
[13]    | MAX | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 |
[14]    | MIN | 関数 | 関数 | 関数 | 関数 | 関数 | 関数 |
[15]    | n1 | 15.3 | 21.4 | 11.2 | 35.3 | 3.3 | 4.6 |
[16]    | n2 | 14.9 | 20.8 | 10.1 | 34.2 | 3.1 | 6.3 |
[17]    | n3 | 14.7 | 20.4 | 10.4 | 35.7 | 3.3 | 6.6 |
           
                最終行まで

のようにM列を起点に3列ずつ1行目から最終行まで結合したいです。
お力をお借りしたく。。
本当に恐縮ですが。宜しくお願いします。

  
プレビューを何度やってもレイアウトのズレが修正できず。。
            

(カラス) 2023/03/07(火) 23:23:27


取り込み中、失礼します。

その変換後のシートは最終のシートで、それを使って計算とかはしないシートですか?
もし、これからも計算に使うシートでしたら、
結合セルは止めた方がいいです。セル幅で調整して下さい。
百害あって一利なしです。

(abc) 2023/03/07(火) 23:59:21


(abc)様
コメントありがとうございます。

これが計算後の最終シートになります。

一番上で書かせてもらいましたが最終的には
隣にシートをコピーしてこの処理を出来たらと考えております。

まずはセルの結合をさせたいのが課題になります。

お客様の指定フォームが1行3列結合したものになっており
相手方の都合もあり改定は出来ないとの事なので。。
(カラス) 2023/03/08(水) 00:16:47


 行と列の使い分けがなされていないので、難解です。
 投稿する前に、落ち着いて読み直すと良いでしょう。
 私が読み取れた形は、下記コードで。
 違ったら廃棄して下さい。
 元表のあるシートを「Sheet1」としています。

    Sub Macro1()
        Dim ws As Worksheet, ts As Worksheet
        Dim rng As Range
        Dim v, w
        Dim i As Long, j As Long, r As Long, c As Long

        Set ws = Worksheets("Sheet1")
        Set ts = Worksheets.Add(after:=ws)
        Set rng = ws.Range("L7")
        v = rng.CurrentRegion.Value
        r = rng.Row + UBound(v)
        c = rng.Column
        For j = 1 To UBound(v, 2)
            w = Application.Index(Application.Transpose(v), j)
            ts.Cells(7, c).Resize(UBound(v)) = Application.Transpose(w)
            If j = 1 Then
                c = c + 1
            Else
                ts.Range(ts.Cells(1, c), ts.Cells(r, c + 2)).Merge True
                c = c + 3
            End If
        Next
    End Sub

(缶ピー) 2023/03/08(水) 07:04:59


(缶ピー)様
コメントありがとうございました。
本当にご迷惑をおかけしており申し訳ありません。

ts.Range(ts.Cells(1, c), ts.Cells(r, c + 2)).Merge True

の部分で実行時エラー1004が出て動きませんでした。。
自分の知能と説明力の無さが情けないです。

(カラス) 2023/03/08(水) 08:17:49


 よく分かってませんがつくってみました
    Sub sample()
      Dim ws As Worksheet, nws As Worksheet
      Dim nRow As Long, nCol As Long
      Dim buf() As Variant
      Set ws = ActiveSheet
      nRow = ws.Range("M15").End(xlDown).Row - 14
      nCol = ws.Range("M15").End(xlToRight).Column - 12
      buf() = ws.Range("M15").Resize(nRow, nCol * 3).Value
      For i = 1 To nRow
         For j = nCol To 1 Step -1
             buf(i, j * 3 - 2) = buf(i, j)
             buf(i, j * 3 - 1) = ""
             buf(i, j * 3) = ""
         Next
      Next
      Set nws = Worksheets.Add(after:=ws)
      With nws.Range("M15").Resize(nRow, nCol * 3)
          .Cells(1, 1).Resize(, 3).Merge
          .Cells(1, 1).MergeArea.Copy
          .Cells(1, 1).MergeArea.Offset(, 1).Resize(, (nCol - 1) * 3).PasteSpecial
          .Rows(1).Copy
          .Rows(2).Resize(nRow - 1).PasteSpecial
          .Value = buf
      End With
    End Sub
(´・ω・`) 2023/03/08(水) 09:02:10

(´・ω・`)様
コメントとコードを本当にありがとうございます。

実行させて頂きました。
挙動としてはM列15行目から始まるセルが3列結合してくれて
自分の希望イメージに近いものを頂けて感謝です。

・M列からは15行目から最終行までセル結合されていますが
1行目〜14行目も3列をセル結合させたい

・A列〜L列は丸ごとそのままシート先のA列〜L列に
セルの結合などはせずにコピーする 

これが出来れば大変ありがたく思っております。
クレクレ君になってしまっていて大変申し訳ありません。

(カラス) 2023/03/08(水) 11:59:26


確認ですが、レイアウトの説明に"関数"とあるのは、そこに式が入っているという意味ですか?
もしそうなら、できあがりも式になっていて、問題ないのですか?

(abc) 2023/03/08(水) 12:47:30


(abc)様
コメントありがとうございます。

ご指摘頂いたセルには数式が入っております。
出来上がり(出力したシート)には

・式が反映されていれば(元のM列の数式→MNO列に数式、元のN列に数式→PQR列へ、のように)
大変ありがたいですが

・数式では無く元のシートの数値や文字が貼り付けられるだけ
でも全く問題無いです。

どちらのパターンでも後に不都合が出ない事は確認しておりますので
運用させて欲しく思います。

すみませんが宜しくお願い致します。

(カラス) 2023/03/08(水) 12:58:41


 こういうことっすか?
 列数と行数は固定ではないので、動的に変更したい
 7行目の「項目」が空白になるまで繰り返す条件でこんなんどうでしょう?

 変換前
     |[L] |[M] |[N] |[O] |[P] |[Q] |[R] 
 [1] |    |    |    |    |    |    |    
 [2] |    |    |    |    |    |    |    
 [3] |    |    |    |    |    |    |    
 [4] |    |    |    |    |    |    |    
 [5] |    |    |    |    |    |    |    
 [6] |    |    |    |    |    |    |    
 [7] |項目|   1|   2|   3|   4|   5|   6
 [8] |規格|  15|  20|  10|  33|   3|   5
 [9] |上限|  16|  22|  11|  36| 3.5|   6
 [10]|下限|  14|  18|   9|  30| 2.5|   4
 [11]|範囲|関数|関数|関数|関数|関数|関数
 [12]|平均|関数|関数|関数|関数|関数|関数
 [13]|MAX |関数|関数|関数|関数|関数|関数
 [14]|MIN |関数|関数|関数|関数|関数|関数
 [15]|n1  |15.3|21.4|11.2|35.3| 3.3| 4.6
 [16]|n2  |14.9|20.8|10.1|34.2| 3.1| 6.3
 [17]|n3  |14.7|20.4|10.4|35.7| 3.3| 6.6

 変換後
     |[L] |[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD] |
 [1] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [2] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [3] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [4] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [5] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [6] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [7] |項目|           1|           2|           3|           4|            5|              6|
 [8] |規格|          15|          20|          10|          33|            3|              5|
 [9] |上限|          16|          22|          11|          36|          3.5|              6|
 [10]|下限|          14|          18|           9|          30|          2.5|              4|
 [11]|範囲|        関数|        関数|        関数|        関数|         関数|           関数|
 [12]|平均|        関数|        関数|        関数|        関数|         関数|           関数|
 [13]|MAX |        関数|        関数|        関数|        関数|         関数|           関数|
 [14]|MIN |        関数|        関数|        関数|        関数|         関数|           関数|
 [15]|n1  |        15.3|        21.4|        11.2|        35.3|          3.3|            4.6|
 [16]|n2  |        14.9|        20.8|        10.1|        34.2|          3.1|            6.3|
 [17]|n3  |        14.7|        20.4|        10.4|        35.7|          3.3|            6.6|  

    Option Explicit
    Sub test()
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Const fld_rw As Long = 7
        cl = [m1].Column
        end_rw = Cells(Rows.Count, "L").End(xlUp).Row
        Do Until Cells(fld_rw, cl).Value = ""
            Cells(1, cl).Resize(, 2).EntireColumn.Insert
            For rw = fld_rw To end_rw
                Cells(rw, cl).Resize(, 3).Merge
            Next rw
            cl = cl + 3
        Loop
    End Sub

(稲葉) 2023/03/08(水) 18:07:59


    Sub sample()
      Dim ws As Worksheet
      ActiveSheet.Copy after:=ActiveSheet
      Set ws = ActiveSheet
      Dim i As Long, j As Long
      Dim nRow As Long, nCol As Long
      nRow = ws.Range("M15").End(xlDown).Row
      nCol = ws.Range("M15").End(xlToRight).Column
      For j = nCol To 13 Step -1
          With ws.Columns(j).Resize(nRow)
              .Offset(, 1).Resize(, 2).Insert shift:=xlToRight
              For Each r In .Resize(, 3).Rows
                  r.Merge
              Next
          End With
      Next
    End Sub
(´・ω・`) 2023/03/08(水) 20:14:53

(稲葉)様
(´・ω・`)様

コメントとコードをプレゼントして頂き、、本当に、本当にありがとうございます。

お二方の下さったものをそれぞれ実行致しました。
どちらのコードも私のやりたかった完全な理想形になり感謝しきれません。

大切に保存して勉強して活用出来るようにします。
本当に本当にありがとうございました!!!!
(カラス) 2023/03/08(水) 20:29:47


(´・ω・`)様

ご相談があります。
プレゼント頂きました上記コードでエラーが発現してしまいました。

事象としましては。M列にのみ数値が入っていた場合

.Offset(, 1).Resize(, 2).Insert Shift:=xlToRight
でエラーで止まってしまいます。

複数列が埋まることがほとんどだったので。想定しておらず申し訳ないです。

M列のみ入力されていた場合も他の列と同様に3列を結合するような修正は可能でしょうか。
すみません。
(カラス) 2023/03/10(金) 01:06:37


 こうですか
    Sub sample()
      Dim ws As Worksheet
      ActiveSheet.Copy after:=ActiveSheet
      Set ws = ActiveSheet
      Dim i As Long, j As Long
      Dim nRow As Long, nCol As Long
      nRow = ws.Range("M15").End(xlDown).Row
      nCol = ws.Range("M15").End(xlToRight).Column
      If nRow = Rows.Count Then nRow = 15
      If nCol = Columns.Count Then nCol = 13
      Stop
      For j = nCol To 13 Step -1
          With ws.Columns(j).Resize(nRow)
              .Offset(, 1).Resize(, 2).Insert shift:=xlToRight
              For Each r In .Resize(, 3).Rows
                  r.Merge
              Next
          End With
      Next
    End Sub
(´・ω・`) 2023/03/10(金) 06:12:19

(´・ω・`) 様
早急にプレゼント頂きありがとうございます。
本当に、本当にありがとうございます。
動作が完璧になりました。感謝しきれません。。
(カラス) 2023/03/10(金) 08:25:18

列によって行数が異なるパターンでもセルの結合が
うまくいかなくなる事がわかりました。

M列が12行 
N列が14行
O列が7行など

このパターンの時には
(稲葉) 様から頂けたコードが結合をズレなくやってもらえる事がわかりました。
 
ただ、関数によっては結合後に参照がズレる?
(´・ω・`) 様のコードは関数の参照がズレない

お二方のどちらのコードも素晴らしいです。
何とか、いいとこ取り出来る方法を考えてみます。

(カラス) 2023/03/10(金) 13:01:48


 私のコードは列全体を値が入力されているセルの左側に挿入後に結合させてます。
 (´・ω・`)さんのコードは、値が入力されたセルの右側に挿入して結合させてます。
 なので、同じように直せばずれないのかしら?
    Sub test()
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Const fld_rw As Long = 7
        cl = [m1].Column
        end_rw = Cells(Rows.Count, "L").End(xlUp).Row
        Do Until Cells(fld_rw, cl).Value = ""
            Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert’★変更点
            For rw = fld_rw To end_rw
                Cells(rw, cl).Resize(, 3).Merge
            Next rw
            cl = cl + 3
        Loop
    End Sub

(稲葉) 2023/03/10(金) 14:13:22


(稲葉) 様

改良版をプレゼント頂きありがとうございます。
埋まっている行が違っていてもセルの結合のズレ、未結合も無くなり
関数の参照のズレも無くなりました。

多大な感謝を申し上げます。
本当に本当にありがとうございます。
(カラス) 2023/03/10(金) 19:21:06


すみません、知恵をお借りしたくて再投稿させて頂きます。
(稲葉様から頂いたコードで結合に関しては大変、便利というか必須級で使わせていただいております。

基本的にこのコードと今の使用しているフォームを合わせて調整したのですが、
今年度から新しいフォーマットに改定されると新しいテンプレが回ってきました。

それに合わせて何とかコードも今のうちに近づけておけないかと考えております。

Sub シートコピー展開()

    On Error Resume Next 'エラー回避のための記述

    Application.DisplayAlerts = False '警告メッセージ非表示

    Worksheets("新フォーム用").Delete

    Application.DisplayAlerts = True '警告メッセージ表示

    Worksheets("土台").Copy After:=Worksheets(Worksheets.count)

    ActiveSheet.Name = "新フォーム用"

End Sub

これでまず練習の土台を作っております。

投稿を分けさせて頂きます。
(カラス) 2023/03/13(月) 21:55:01


変換前
     |[L] |[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD] |

 [6] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [7] |項目|           1|           2|           3|           4|            5|              6|
 [8] |規格|          15|          20|          10|          33|          3.1|              8|
 [9] |上限|           1|           1|           2|           3|          0.5|              1|
[10] |下限|          -1|          -1|          -2|          -3|         -0.5|             -1|
[11] |  |            |            |            |            |             |               |
[12] |  |            |            |            |            |             |               |
[13] |  |            |            |            |            |             |               |
[14] |設備|           B|           C|           C|           E|            E|              A|
[15] |  |          15|          21|          10|          33|          3.3|              5|
[16] |  |          16|          20|          11|          34|          3.5|              4|
[17] |  |          13|          21|          11|          31|          3.4|              7|

変換後

     |[L ]|[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD]|

 [3] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |    |
 [4] |項目|           1|           2|           3|           4|            5|              6|
 [5] |規格| 15   +  1| 20   +     1| 10   +    2| 33   +    3| 3.1  +    0.5| 8      +       1|  5行目、6行目結合
 [6] |  |      -    1|      -    1|      -    2|      -    3|      -   0.5|       -      1|    5行目、6行目結合
 [7] |設備|           B|           C|           C|           E|            E|              A|
 [8] |  |          15|          21|          10|          33|          3.3|              5|
 [9] |  |          16|          20|          11|          34|          3.5|              4|
[10] |  |          13|          21|          11|          31|          3.4|              7|

・データの始まりが元は15行目→新フォームは始まりが8行目
・新フォームは5,6行目が結合されている
・旧フォームのマイナス公差が新フォームでは記号が独立して
マイナス公差も負の値じゃ無くなる

全く変換するイメージが沸きません。
何か結合にくっつけてやる?ループ?
ご教授を頂きたいです。

なお、(稲葉)様から頂いたコードはもう絶対にも私たくないレベルで厳重に永久保存してあります。
上のような変換はコードじゃ複雑すぎるというものでしたら
諦めもつきます。

すみませんが宜しくお願い致します。

(カラス) 2023/03/13(月) 22:06:16


 回答者は私一人ではないし、相談にのってくれた人にたいしても失礼がないように
 していただいた方が見ていて気持ちいいのと、カラスさんにとっても回答者が増えていいんじゃないかなー
 話戻すと元が結合されてないデータなら、そんなに難しくなあと思いますが、
 明日ゆっくり見ますねー
(稲葉) 2023/03/13(月) 23:28:29

(稲葉様)
コメントありがとうございます。
不快に感じられる点があったことを深くお詫び申し上げます。

上記でプレゼント頂いたコードは全て活用させて頂いております。

私にご教授頂いたすべての方に感謝をしています。

稲葉様、他の方々に改めて謝罪させて頂きます。
言葉足らずで申し訳ありませんでした。

何卒宜しくお願い致します。
(カラス) 2023/03/13(月) 23:41:47


 これで合ってますかね?
 っとここまで書いてて思ったけど、結合後のデータを変換かけたいってこと?
 だとすると面倒だからやだぁ・・・
    Sub 実行()
        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)

        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&"" + ""&<上限>"
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With
        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)
        MsgBox "完了しました"
    End Sub

    '使いまわし L列にn1とか入力がないのでUsedRangeで最終行の判定
    Sub セル結合(ws As Worksheet)
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Const fld_rw As Long = 4 '開始行
        With ws
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
            Do Until .Cells(fld_rw, cl).Value = ""
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert                 For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3
            Loop
        End With
    End Sub
(稲葉) 2023/03/14(火) 13:51:28

ここまでご尽力下さったのに私のミスで
本当にご迷惑とお礼を申し上げます。

セルの結合の記入ミスで、更に複雑でした。。

変換後

     |[L ]|[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD]|
 [3] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |    |
 [4] |項目|           1|           2|           3|           4|            5|              6|
 [5] |規格| 15 | + |  1| 20 | + |  1| 10 | + |  2| 33 | + |  3| 3.1| + | 0.5| 8  |  + |    1|  
 [6] |↑結|↑結| - |  1|↑結| - |  1|↑結| - | 2|↑結| - |  3|↑結 | - | 0.5|↑結|  - |    1|    
 [7] |設備|           B|           C|           C|           E|            E|              A|
 [8] |  |          15|          21|          10|          33|          3.3|              5|
 [9] |  |          16|          20|          11|          34|          3.5|              4|
[10] |  |          13|          21|          11|          31|          3.4|              7|

もう土下座してお詫びしたいくらい申し訳ないので、
頂いたコードは全て保存させてもらい何とか自分で改良策を考えようと思います。
本当にありがとうございました。
(カラス) 2023/03/14(火) 19:13:15


 M5:M6が結合
 NとOは独立セル?
(稲葉) 2023/03/14(火) 19:42:44

(稲葉)様、コメント本当にありがとうございます。

おっしゃる通りになります。

NとOは5行目,6行目で独立しております。
そしてM5とM6が行で結合しております。

上手く説明できず申し訳ないですが、3列の結合している一番左の5行目と6行目が
結合する形になっております。

結合された3列の5行目と6行目でセルの結合を解除

その左列の5行目と6行目で行を結合

といったフォーマットになっています。
本当に、本当にご迷惑をおかけして申し訳ありませんでした。

(カラス) 2023/03/14(火) 22:09:28


 これで想定通りだと思う
 見るためだけの表なのかな?
    Sub 実行()
        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)
        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&""/+/""&<上限>" '後でSplitで分解できるように/を入れておく
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With
        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)
        MsgBox "完了しました"
    End Sub
    '使いまわし L列にn1とか入力がないのでUsedRangeで最終行の判定
    Sub セル結合(ws As Worksheet)
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Const fld_rw As Long = 7 '開始行
        With ws
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With

            'タイトル列の「規格」を上下に結合
            DisAlr False
            .[L5:L6].Merge
            DisAlr True

            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert

                '5行目 規格値 | + | プラス公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")

                '6行目 - | マイナス公差
                .Cells(6, cl + 1).Value = "-"
                .Cells(6, cl + 2).Value = -1 * .Cells(6, cl).Value

                '各項目の1列目 5-6行、項目名4行目横に3列分結合
                DisAlr False
                .Cells(5, cl).Resize(2).Merge
                .Cells(4, cl).Resize(, 3).Merge
                DisAlr True

                For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3
            Loop
        End With
    End Sub
    Sub DisAlr(flg As Boolean)
        Application.DisplayAlerts = flg
    End Sub

(稲葉) 2023/03/15(水) 11:13:26


(稲葉)様、 本当にご尽力頂きありがとうございます。
そして要望するばかりの形でご迷惑をおかけして大変申し訳ありません。

頂いたコードを試させて頂きました。
セルの配列や結合が本当に一致して素晴らしく。大変感致します。

見るためだけではなく、変換されたフォーマットへ
4行目からをコピーして新フォームへそのまま貼付けをしたく思っております。
(値をコピーだとセルの結合エラーになるので数式の貼付け、これで良いです。)

コードに全く問題は無く、元のシートが原因が思うのですが挙動が大変重く、
フリーズ→1分くらい待つ、→完了
になります。

頂いたものの前に
Application.ScreenUpdating = False '画面描画を停止
Application.EnableEvents = False 'イベントを抑止
Application.Calculation = xlCalculationManual '計算を手動に

を追加したりしているのですが、現状ではなかなか挙動が軽くならないので

そこは元のブックの関数を減らしたり自分なりに試行錯誤します。

(元のブックの3,4,5行目にもよく見たら関数が入っていました…コード実行後のシートには
あってもなくてもいいので多分これを消せば軽くなるかな?という)
ここに関しては自分でマクロの記録など使って試していこうと思います。

あとは規格公差の変換がうまくいけばと望んでおります。

 
次の投稿へ続く

(カラス) 2023/03/15(水) 18:41:07


返還前
     |[L] |[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD] |
 [6] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |     |
 [7] |項目|           1|           2|           3|           4|            5|              6|
 [8] |規格|          15|          20|          10|          33|          3.1|              8|
 [9] |上限|          -2|           3|           0|           3|          0.5|              1|
[10] |下限|          -1|           1|          -2|           2|         -0.5|             -1|

変換後

     |[L ]|[M] |[N]|[O]|[P] |[Q]|[R]|[S] |[T]|[U]|[V] |[W]|[X]|[Y] |[Z]|[AA]|[AB]|[AC]|[AD]|
 [3] |    |    |   |   |    |   |   |    |   |   |    |   |   |    |   |    |    |    |    |
 [4] |項目|           1|           2|           3|           4|            5|              6|
 [5] |規格| 15 | - |  2| 20 | + |  3| 10 | + |  0| 33 | + |  3| 3.1| + | 0.5| 8  |  + |    1|  
 [6] |↑結|↑結| - |  1|↑結| + |  1|↑結| - | 2|↑結| + |  2|↑結 | - | 0.5|↑結|  - |    1|    

返還前の上限が正の値だった場合→変換後の上限の値の左の記号を+に
返還前の上限が負の値だった場合→変換後の上限の値の左の記号を-に
返還前の上限が0の値だった場合→変換後の上限の値の左の記号は+に

返還前の下限が正の値だった場合→変換後の下限の値の左の記号を+に
返還前の下限が負の値だった場合→変換後の下限の値の左の記号を-に
返還前の下限が0の値だった場合→変換後の下限の値の左の記号は+に

規格がプラス公差、マイナス公差、などのパターンが課題になります。。
(カラス) 2023/03/15(水) 18:54:48


 後だし条件はやめてほしかったなぁ
 Do-Loopの前後部分だけ変更
 テストしてない
            Application.Calculation = xlCalculationManual '★
            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert
                '5行目 規格値 | +- | プラス公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
                .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value > 0, "+", "-") '★
                .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★
                '6行目 +- | 下限公差
                .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★
                .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★
                '各項目の1列目 5-6行、項目名4行目横に3列分結合
                DisAlr False
                .Cells(5, cl).Resize(2).Merge
                .Cells(4, cl).Resize(, 3).Merge
                DisAlr True
                For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3
            Loop
            Application.Calculation = xlCalculationAutomatic '★
(稲葉) 2023/03/15(水) 19:06:37

(稲葉)様
コメントとコード、同じ言葉になってしまいますが本当に感謝致します。
自分の確認不足、言葉足らずにより何度も後出しになってしまいご迷惑をおかけしました。
本当にありがとうございます。

規格の記号も理想の通りに変換されて感無量です。

変更後の2行で結合された規格の値の個所が
数値が文字列として保存されています。

となるのを処置出来ればもう完成ですのでこれはネットで探して
マクロを割り当てられるか自分でコードを検証してみます。

本当に、ありがとうございます。

(カラス) 2023/03/15(水) 21:31:24


頂いたコードに素人ながら付け加えて数値に変換させる事が出来ました。
データの量にもよりますが、実行して5分くらいでなんとかいけそうです。
ありがとうございました。

Sub 実行()

        Application.ScreenUpdating = False                       '画面描画を停止
        Application.EnableEvents = False                         'イベントを抑止
        Application.Calculation = xlCalculationManual            '計算を手動に

        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("元のブック").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)

        Range("A:D").ClearContents
        Range("3:5").ClearContents

        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&""/+/""&<上限>" '後でSplitで分解できるように/を入れておく
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With
        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)
        MsgBox "完了しました"

    End Sub
    '使いまわし L列にn1とか入力がないのでUsedRangeで最終行の判定
    Sub セル結合(ws As Worksheet)

        Application.ScreenUpdating = False                       '画面描画を停止
        Application.EnableEvents = False                         'イベントを抑止
        Application.Calculation = xlCalculationManual            '計算を手動に

        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long

        Const fld_rw As Long = 7 '開始行
        With ws
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
            'タイトル列の「規格」を上下に結合
            DisAlr False
            .[L5:L6].Merge
            DisAlr True
           Application.Calculation = xlCalculationManual '★
            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert
                '5行目 規格値 | +- | プラス公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
                .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value > 0, "+", "-") '★
                .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★
                '6行目 +- | 下限公差
                .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★
                .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★
                '各項目の1列目 5-6行、項目名4行目横に3列分結合
                DisAlr False
                .Cells(5, cl).Resize(2).Merge
                .Cells(4, cl).Resize(, 3).Merge
                DisAlr True
                For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3
            Loop
        End With

        With Intersect(ActiveSheet.UsedRange, Columns("M:WO"))
         .NumberFormat = ""
         .Value = .Value
        End With

         Columns("M:WO").ColumnWidth = 4.4
         Range("A6").Select

    End Sub
    Sub DisAlr(flg As Boolean)
            Application.DisplayAlerts = flg

            Application.ScreenUpdating = True                         '画面描画を再開
            Application.EnableEvents = True                           'イベントを再開
            Application.Calculation = xlCalculationAutomatic          '計算を自動に戻す

    End Sub
(カラス) 2023/03/15(水) 23:27:14

 一部無駄な処理があったので、手直ししました。

    Sub 実行()
        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("元のブック").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)
        Range("A:D").ClearContents
        Range("3:5").ClearContents
        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&""/+/""&<上限>" '後でSplitで分解できるように/を入れておく
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With

        'ここから時間の掛かる処理
        Application.ScreenUpdating = False                       '画面描画を停止
        Application.EnableEvents = False                         'イベントを抑止 注意EnableEventsはTrueに戻すまでFalseのまま
        Application.Calculation = xlCalculationManua            '計算を手動に
        '!! 注意 !! 手動計算はTrueに戻すまでFalseのままで、手動のまま保存してしまうと、
        '手動の設定が残ってしまうため取り扱うに注意すること

        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)

        Application.ScreenUpdating = True                       '画面描画を開始
        Application.EnableEvents = True                         'イベントを開始
        Application.Calculation = xlCalculationAutomatic        '自動計算に戻す
        '時間のかかる処理 ここまで

        MsgBox "完了しました"
    End Sub
    '使いまわし L列にn1とか入力がないのでUsedRangeで最終行の判定
    Sub セル結合(ws As Worksheet)
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Dim cnt As Long
        Const fld_rw As Long = 7 '開始行
        With ws
            cnt = 1
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
            'タイトル列の「規格」を上下に結合
            DisAlr False
            .[L5:L6].Merge
            DisAlr True
            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert

                '5行目 規格値 | +- | 上限公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
                .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value > 0, "+", "-") '★
                .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★

                '6行目 +- | 下限公差
                .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★
                .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★

                '各項目の1列目 5-6行、項目名4行目横に3列分結合
                DisAlr False
                .Cells(5, cl).Resize(2).Merge
                .Cells(4, cl).Resize(, 3).Merge
                DisAlr True
                For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3

                '応答なし回避 10項目ごとにシステムに制御を渡す
                cnt = cnt + 1
                If cnt Mod 10 = 0 Then DoEvents
            Loop
            With Intersect(.UsedRange, .Columns("M:WO"))
                .NumberFormat = ""
                .Value = .Value
            End With
            .Columns("M:WO").ColumnWidth = 4.4
            .Range("A6").Select
        End With
    End Sub
    Sub DisAlr(flg As Boolean)
        Application.DisplayAlerts = flg
    End Sub

(稲葉) 2023/03/16(木) 08:32:58


(稲葉)様
ありがとう、ございます。
会社のPCでやると処理が重すぎてフリーズの方が多くなってしまいます。
ここで処理が重いこともわかり変更しましたが
やはり、処理が遅く、7列50行くらいのデータになると厳しいです。
処理後は完璧なのですが。

'数値に変換
With Intersect(.UsedRange, .Columns("M:WO"))

                .NumberFormat = ""
                .Value = .Value
End With


'数値に変換
With Intersect(.UsedRange, .Rows("5:6"))

                .NumberFormat = ""
                .Value = .Value
End With

に変更して少し処理が軽くなりましたが、、厳しいです、。

(きつね) 2023/03/16(木) 13:55:22


きつね?
(?) 2023/03/16(木) 14:26:55

大変すみません、今回、スマホからの投稿になり
IMEの自称登録でか行で動物変換をしている関係で誤入力にしてしまいました。
カラスになります。
(カラス) 2023/03/16(木) 15:06:07

お世話になります。会社のPCで実際に何度も実行しました。

歯を食いしばる思いでPCが処理を終えてくれた後は
新フォーマットに完全に貼付け可能、公差の反映も完全に一致して超効率化する事が出来ました。

ただ処理に負けてPCが完全フリーズしてしまう事が多く、タスクマネージャから強制終了。
100か0状態です。
3DCADを扱うような高スペックなPCでは無い為、ここがパソコンの頑張り次第になっております。

何卒、助言を頂ければ幸いです。
マクロのコード以外でも何かあれば御指南頂きたい状況です。
ですが、関数も最小限に削っております。ぐぎぎぎ。すみません。

Sub 実行() '稲葉様モデルを少しいじりバージョン

        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("元祖ブック").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)

        Range("A:D").ClearContents                                                                                        '''不要な関数を削除
        Range("3:5").ClearContents

        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&""/+/""&<上限>" '後でSplitで分解できるように/を入れておく
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With
        'ここから時間の掛かる処理
        Application.ScreenUpdating = False                       '画面描画を停止
        Application.EnableEvents = False                         'イベントを抑止 注意EnableEventsはTrueに戻すまでFalseのまま
        Application.Calculation = xlCalculationManua            '計算を手動に
        '!! 注意 !! 手動計算はTrueに戻すまでFalseのままで、手動のまま保存してしまうと、
        '手動の設定が残ってしまうため取り扱うに注意すること
        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)
        Application.ScreenUpdating = True                       '画面描画を開始
        Application.EnableEvents = True                         'イベントを開始
        Application.Calculation = xlCalculationAutomatic        '自動計算に戻す
        '時間のかかる処理 ここまで
       MsgBox "数式での貼付けが可能です。", vbOKOnly, "変換完了"
    End Sub
    '使いまわし L列にn1とか入力がないのでUsedRangeで最終行の判定
    Sub セル結合(ws As Worksheet)
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Dim cnt As Long
        Const fld_rw As Long = 7 '開始行
        With ws
            cnt = 1
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
            'タイトル列の「規格」を上下に結合
            DisAlr False
            .[L5:L6].Merge
            DisAlr True
            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert
                '5行目 規格値 | +- | 上限公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
                .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value >= 0, "+", "-") '★                          '''上限は0だった場合、以上で+にする
                .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★
                '6行目 +- | 下限公差
                .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★                               '''下限は0だった場合、よりのまま-
                .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★
                '各項目の1列目 5-6行、項目名4行目横に3列分結合
                DisAlr False
                .Cells(5, cl).Resize(2).Merge
                .Cells(4, cl).Resize(, 3).Merge
                DisAlr True
                For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw
                cl = cl + 3
                '応答なし回避 10項目ごとにシステムに制御を渡す
                cnt = cnt + 1
                If cnt Mod 10 = 0 Then DoEvents
            Loop
            With Intersect(.UsedRange, .Rows("5:6"))                                                               '''5行目6行目だけ数値に変換してくれればいい。処理速度速くなる
                .NumberFormat = ""
                .Value = .Value
            End With
            .Columns("M:WO").ColumnWidth = 4.4
            .Range("A1").Select
        End With
    End Sub
    Sub DisAlr(flg As Boolean)
        Application.DisplayAlerts = flg
    End Sub

(カラス) 2023/03/16(木) 18:05:17


 まずステップ実行して、どこが時間かかるか教えてもらえませんか?
 適当なタイミングでStop入れて、時間がかかる部分特定しないと無駄な作業が・・・
(稲葉) 2023/03/16(木) 18:21:14

(稲葉)様
本当にご迷惑をおかけします。コメントありがとうございます。

     For rw = fld_rw To end_rw
                    .Cells(rw, cl).Resize(, 3).Merge
                Next rw

ここでの繰り返し処理が非常に重く、ステップ実行でもフリーズを起こしております。
本当に申し訳ありません。何卒宜しくお願い致します。

(カラス) 2023/03/16(木) 19:01:34


    .Cells(rw, cl).Resize(, 3).Merge
                Next rw

すみません、この2行になります。これの繰り返し処理でフリーズします。

(カラス) 2023/03/16(木) 19:04:29


 それはもはや結合やめるしかないと思うんだけど・・・
(稲葉) 2023/03/16(木) 19:14:14

.Cells(rw, cl).Resize(, 3).Merge
                Next rw

シートを確認すると
ここの処理で最終行以降の空白行もずっとセル結合をしてくれているようです。

ここを空白になるまで、(最終行まで)セル結合、
終わったら次の列
と、都合よく行かないものでしょうか。
意見ばかりですみません。。

(カラス) 2023/03/16(木) 19:18:38


 そうしてるはずだけど。
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
 そのシートの使用中のセルの最終行を取得して実行してるから
 UserdRangeの範囲が広すぎるんじゃない?
 Sub test()
     With ActiveSheet.UsedRange
        Debug.Print "アドレス="; .Address, "高さ="; .Rows.Count, "幅="; .Columns.Count, "最終行="; .Item(.Rows.Count, .Columns.Count).Row
    End With
 End Sub
 これを実行してイミディエイトウィンドウに何が表示されるか教えてください。
(稲葉) 2023/03/16(木) 19:24:25

(稲葉様)コメントありがとうございます。

イミディエイトウィンドウの表示は下記になります。

アドレス=$A$1:$XJ$3334 高さ= 3334 幅= 634 最終行= 3334
アドレス=$A$1:$XJ$3334 高さ= 3334 幅= 634 最終行= 3334

自宅PCでフリーズしてしまい、実際の処理後の、最終行以降のセルの結合状態を
確認出来ておりません。申し訳ありません。

今回貼り付けたデータの行数は65行であったり110行であったりのデータになります。
宜しくお願致します。

(カラス) 2023/03/16(木) 19:37:17


連投すみません。
3334行まで条件付き書式の設定を使用しております。

ブックをコピーしたタイミング?結合の処理がされる前のタイミング?の段階で
でシート全体の条件付き書式をクリアさせればいけそうですかね?!

調べて追加してみます。申し訳ありません。

(カラス) 2023/03/16(木) 19:45:12


 >条件付き書式の設定
 これめちゃくちゃ重いから、そんなに大きな表に使わないほうがいいです。
(稲葉) 2023/03/16(木) 19:59:25

(稲葉様)
コメントありがとうございます。
色々試しましたがダメでした。

コピー後に下記を追加
Cells.FormatConditions.Delete 'シート全体の書式をクリア

挙動が変わらず最終行以降も空白行に対してセルの結合をしてくれてしまう。

元のブックの条件付き書式を全クリア

挙動が変わらず最終行以降も空白行に対してセルの結合をしてくれてしまう。

でした。セルの色?なのでしょうか、、

(カラス) 2023/03/16(木) 20:17:58


 最終行は3334ってなってますがあってますか?

 For rw = fld_rw To end_rw
 を
 For rw = fld_rw To .Cells(Rows.count,cl).end(xlup).Row
 に変更すればその列の最終行は見てくれますが、他の列がそれ以上、それ以下だと
 結合がガタガタになりますがいいんですか?

(稲葉) 2023/03/16(木) 20:38:43


(稲葉)様
コメントありがとうございます。

下記のコードが正確かどうかも全くわかっていないですが
処理前にこれを実行させ範囲内の列の最終行より下を削除させることで
処理がめちゃくちゃ早くなりました

条件付き書式も入れたままでも問題なく出来ました!
これで普段は処理する行と速度を最小限に出来るのかなというのが自分の知識の限界です。

何度試してもモタつくことなく処理が出来るようになりました。
プレゼントして頂いたコードがなければ一生自分ではできませんでした。
本当に、本当にありがとうございます。

    Dim StartRow As Long

    StartRow = Range("L3333").End(xlUp).Row + 1 ' 開始行を取得

    If StartRow > 3334 Then ' 開始行が3334を超える場合は、3335行目以降の行をクリアする
        Rows(3335 & ":" & Rows.Count).ClearContents
    Else ' 開始行から最終行までのすべての行を削除する
        Range("L" & StartRow & ":WO" & Rows.Count).EntireRow.Delete

    End If

(カラス) 2023/03/16(木) 20:53:16


 結合部分ちょっと改善
 列単位でまとめて実行
 最後に↑で実行した部分をコピーして、書式貼り付けですべての列に適用
 これで相当速度上がったはず。

    Sub 実行()
        Dim ws As Worksheet
        Dim fx As String
        'シートをコピーし、コピー後のシートで書式を変更。
        'シート名は適宜変更
        Sheets("元のブック").Copy after:=Sheets(Sheets.Count)
        Set ws = Sheets(Sheets.Count)
        '規格を「規格 + 上限」の値に変更
        With ws.Range("M8", ws.Cells(8, Columns.Count).End(xlToLeft))
            fx = "=<規格>&""/+/""&<上限>" '後でSplitで分解できるように/を入れておく
            fx = Replace(fx, "<規格>", .Address)
            fx = Replace(fx, "<上限>", .Offset(1).Address)
            .Value = Evaluate(fx)
        End With
        'ここから時間の掛かる処理
        Application.ScreenUpdating = False                       '画面描画を停止
        Application.EnableEvents = False                         'イベントを抑止 注意EnableEventsはTrueに戻すまでFalseのまま
        Application.Calculation = xlCalculationManual            '計算を手動に
        '!! 注意 !! 手動計算はTrueに戻すまでFalseのままで、手動のまま保存してしまうと、
        '手動の設定が残ってしまうため取り扱うに注意すること
        'いらない行の削除(まとめて実行しないと、行がずれるので注意。)
        ws.Range("1:3,9:9,11:13").Delete
        'セルの結合は前回のコードを使いまわす
        Call セル結合(ws)
        Application.ScreenUpdating = True                       '画面描画を開始
        Application.EnableEvents = True                         'イベントを開始
        Application.Calculation = xlCalculationAutomatic        '自動計算に戻す
        '時間のかかる処理 ここまで
        MsgBox "完了しました"
    End Sub
    Sub セル結合(ws As Worksheet)
        Dim cl As Long
        Dim rw As Long
        Dim end_rw As Long
        Dim cnt As Long
        Const fld_rw As Long = 7 '開始行
        With ws
            cnt = 1
            cl = .[m1].Column
            With .UsedRange
                end_rw = .Item(.Rows.Count, .Columns.Count).Row '変更点
            End With
            'タイトル列の「規格」を上下に結合
            DisAlr False
            .[L5:L6].Merge
            DisAlr True

            '各項目の2列目から2列分列の挿入
            .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert
            '5行目 規格値 | +- | 上限公差
            .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
            .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value >= 0, "+", "-") '★                          '''上限は0だった場合、以上で+にする
            .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★

            '6行目 +- | 下限公差
            .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★                               '''下限は0だった場合、よりのまま-
            .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★

            '最初の1列目だけセルを結合して置き、全体は書式の貼り付けて結合させる
            '各項目の1列目 5-6行、項目名4行目横に3列分結合
            DisAlr False
                .Cells(4, cl).Resize(, 3).Merge
                .Cells(5, cl).Resize(2).Merge
                Call 初回セル結合(ws, fld_rw, end_rw, cl)
            DisAlr True
            cl = cl + 3

            '4行目の項目名が空白になるまで繰り返す
            Do Until .Cells(4, cl).Value = ""
                '各項目の2列目から2列分列の挿入
                .Cells(1, cl + 1).Resize(, 2).EntireColumn.Insert
                '5行目 規格値 | +- | 上限公差
                .Cells(5, cl).Resize(, 3).Value = Split(.Cells(5, cl).Value, "/")
                .Cells(5, cl + 1).Value = IIf(.Cells(5, cl + 2).Value >= 0, "+", "-") '★                          '''上限は0だった場合、以上で+にする
                .Cells(5, cl + 2).Value = Abs(.Cells(5, cl + 2).Value) '★
                '6行目 +- | 下限公差
                .Cells(6, cl + 1).Value = IIf(.Cells(6, cl).Value > 0, "+", "-") '★                               '''下限は0だった場合、よりのまま-
                .Cells(6, cl + 2).Value = Abs(.Cells(6, cl).Value) '★
                cl = cl + 3
                '応答なし回避 10項目ごとにシステムに制御を渡す
                cnt = cnt + 1
                If cnt Mod 10 = 0 Then DoEvents
            Loop
            DisAlr False
                .Range("M4:O" & end_rw).Copy
                .Range("P4:P" & end_rw).Resize(, cl).PasteSpecial Paste:=xlPasteFormats
            DisAlr True
            With Intersect(.UsedRange, .Rows("5:6"))                                                               '''5行目6行目だけ数値に変換してくれればいい。処理速度速くなる
                .NumberFormat = ""
                .Value = .Value
            End With
            .Columns("M:WO").ColumnWidth = 4.4
            .Range("A1").Select
        End With
    End Sub
    Sub DisAlr(flg As Boolean)
        Application.DisplayAlerts = flg
    End Sub
    Sub 初回セル結合(ws As Worksheet, rfrom As Long, rto As Long, cl As Long)
        Dim buf As String
        Dim intMoji As Long
        Dim cnt As Long
        Dim rng As String
        Dim i As Long
        '255文字分まとめて結合を繰り返す
        rng = String(255, " ")
        For i = rfrom To rto
            buf = Cells(i, cl).Resize(, 3).Address(0, 0) & ","
            intMoji = Len(buf)
            If cnt + intMoji > 230 Then
                rng = Left(rng, cnt - 1)
                ws.Range(rng).Merge
                rng = String(255, " ")
                cnt = 0
            End If
            Mid(rng, cnt + 1, intMoji) = buf
            cnt = cnt + intMoji
        Next i
        If cnt > 0 Then
            rng = Left(rng, cnt - 1)
            ws.Range(rng).Merge
        End If
    End Sub
(稲葉) 2023/03/17(金) 11:59:01

(稲葉)様、お礼の言葉しかないのを心ぐるしく思います。

前回のコードでもボタンで実行をさせているのを見た
同僚がすごすぎてドン引きしていました。

プレゼント頂いた改良版、試させて頂きました。
もう処理が更に爆速になりました。。

もう凄すぎて。。
わざと業務で来るであろう最大データ量の2倍近くにしても
爆速で出力が終わるようになりました。

本当に、本当に、ありがとうございます。
本当に爆速すぎて。心よりお礼申し上げます。
表現できないくらい爆速です。

(カラス) 2023/03/17(金) 22:57:08


 お役に立てて良かったです。
 次質問される時は、データ範囲の大きさや、
 実際に想定されるであろうデータに則した例(今回は上限公差のプラスマイナス)
 正確なアウトプット情報(上下結合など)心がけていただけるとありがたいです
(稲葉) 2023/03/18(土) 07:26:02

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.