Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
352 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【75380】Re:以前作って頂いた物の改変(複雑です)
発言  kanabun  - 14/3/18(火) 12:49 -
引用なし
パスワード
   ▼初心者M さん：

>それをまた、別のファイルで使うために改変しようとし、試行錯誤の末行き詰まってしまったので、申し訳ございませんがまたお知恵を貸して頂きたいです。

>　　For x = X0 To X0 + (XX - 1) * Xstp Step Xstp　'取り込んだ最大値を上書き
>　　　For y = Y0 To Y0 + (YY - 1) * Ystp Step Ystp
>　　　　　For Each c In Cells(y, x).Resize(9)
>　　　　　　ss = c.Value
>　　　　　　
>　　　　　　If c.Offset(, 1).Value = 0 Then '掛け数が入力されていたら無視
>
>　　　　　　　　If Len(ss) > 0 Then
>　　　　　　　　　　c.Offset(, 2).Value = dic(ss)
>　　　　　　　　　　
>　　　　　　　　　　'If c.Offset(, 2).Value = 0 Then '０なし
>　　　　　　　　　　'GoTo nxt
>　　　　　　　　　　
>　　　　　　　　　　'If c.Offset(, 1).Value <> 0 Then '←無視された行に色をつけたいが、うまく動かない
>　　　　　　　　　　'c.Offset(, 1).Interior.Color = RGB(0, 128, 0)
>　　　　　　　　　　'c.Offset(, 1).Interior.Coloindex = 10
>　　　　　　　　　　'End If
>　　　　　　　　　　
>　　　　　　　　　　'End If
>　　　　　　　　End If
>　　　　　　End If
>　　　　　　　　　　'nxt:
>　　　　　Next
>　　　　Next
>　　Next
>　
>　MsgBox ("持ち上げが完了しました。掛け数の設定されている台は、手集計して下さい")
>　
>End Sub
>
>___________________________________
>
>やりたいのは、上記の中にもある
>
>１．無視された行に色を付ける
>
>２．最初に読み込むセル(記号の有るセル)を、リサイズした９行の中でも「C9」「C12」「C15」のように３つずつだけにする
>
>３．読み込んだ記号に対応した数値は、例えば「C9」に対し「E8」「E9」「E10」のように３つずつあり、これらを別々の数値として、それぞれ最大値に合わせる(３回回すイメージをしています)。
>
>４．最後に、それぞれの記号に対し、書き込んだ回数をカウントし、特定の数値にに対して違っていたら警告を出したい。
>
>２に関しては、読み込む部分のコードをResize(9)からOffset(1, 0)、Offset(4, 0)、Offset(7, 0)に変えて３回回したら上手く動いたのですが、それ以降が止まってしまいますし、何か違う気がします。

サンプルの表を出して、
この表を こうしたいのだが、こうなってしまう
のように、
絵で説明してくださると、時間のあるとき考えてみるのですが...
・ツリー全体表示
【75379】以前作って頂いた物の改変(複雑です)
質問  初心者M  - 14/3/18(火) 11:09 -
引用なし
パスワード
   度々すみません。
以前こちら、kanabun様に作成していただいたマクロが非常に便利で、大変助かっております。
それをまた、別のファイルで使うために改変しようとし、試行錯誤の末行き詰まってしまったので、申し訳ございませんがまたお知恵を貸して頂きたいです。

ちょっと複雑です。説明が分り辛かったら申し訳ございません。

作っていただき、ちょっと改変して使っているのが、以下の内容です。
Ｃ列にある記号を取得し、同じものが記載されているＥ列の数字を、シート内の最大値に合わせるものです。

素人なりに解析や改変を頑張って、うまく行かない状態の痕跡も、そのまま載せておきます。(うまくいかない部分は動かないようにしてあります)

___________________________________

Sub test6()

　　Dim n As Long
　　Dim y As Integer, x As Integer
　　Dim ss As String
　　Dim c As Range
　　Const Y0 = 8, YY = 84, Ystp = 16 '縦方向 最初の行番・繰り返し回数・Step数
　　Const X0 = 3, XX = 27, Xstp = 3 '横方向 最初の列番・繰り返し回数・Step数
　　Dim dic As Object
　　Set dic = CreateObject("Scripting.Dictionary")　'システム辞書
　
　　For x = X0 To X0 + (XX - 1) * Xstp Step Xstp
　　　For y = Y0 To Y0 + (YY - 1) * Ystp Step Ystp
　　　　　For Each c In Cells(y, x).Resize(9)
　　　　　　ss = c.Value
　　　　　　If Len(ss) > 0 Then
　　　　　　　n = c.Offset(, 2).Value　'数値取り込み
　　　　　　　n = Application.WorksheetFunction.RoundUp(n, -2) '端数繰上げ
　　　　　　　
　　　　　　　If Not dic.Exists(ss) Then　'登録されていない文字なら辞書に追加
　　　　　　　　　dic(ss) = n
　　　　　　　ElseIf dic(ss) < n Then　'取り込んだ数値より大きければ上書き
　　　　　　　　
　　　　　　　　　dic(ss) = n

　　　　　　　End If
　　　　　　End If
　　　　　Next
　　　　Next
　　Next
　　For x = X0 To X0 + (XX - 1) * Xstp Step Xstp　'取り込んだ最大値を上書き
　　　For y = Y0 To Y0 + (YY - 1) * Ystp Step Ystp
　　　　　For Each c In Cells(y, x).Resize(9)
　　　　　　ss = c.Value
　　　　　　
　　　　　　If c.Offset(, 1).Value = 0 Then '掛け数が入力されていたら無視

　　　　　　　　If Len(ss) > 0 Then
　　　　　　　　　　c.Offset(, 2).Value = dic(ss)
　　　　　　　　　　
　　　　　　　　　　'If c.Offset(, 2).Value = 0 Then '０なし
　　　　　　　　　　'GoTo nxt
　　　　　　　　　　
　　　　　　　　　　'If c.Offset(, 1).Value <> 0 Then '←無視された行に色をつけたいが、うまく動かない
　　　　　　　　　　'c.Offset(, 1).Interior.Color = RGB(0, 128, 0)
　　　　　　　　　　'c.Offset(, 1).Interior.Coloindex = 10
　　　　　　　　　　'End If
　　　　　　　　　　
　　　　　　　　　　'End If
　　　　　　　　End If
　　　　　　End If
　　　　　　　　　　'nxt:
　　　　　Next
　　　　Next
　　Next
　
　MsgBox ("持ち上げが完了しました。掛け数の設定されている台は、手集計して下さい")
　
End Sub

___________________________________

やりたいのは、上記の中にもある

１．無視された行に色を付ける

２．最初に読み込むセル(記号の有るセル)を、リサイズした９行の中でも「C9」「C12」「C15」のように３つずつだけにする

３．読み込んだ記号に対応した数値は、例えば「C9」に対し「E8」「E9」「E10」のように３つずつあり、これらを別々の数値として、それぞれ最大値に合わせる(３回回すイメージをしています)。

４．最後に、それぞれの記号に対し、書き込んだ回数をカウントし、特定の数値にに対して違っていたら警告を出したい。

２に関しては、読み込む部分のコードをResize(9)からOffset(1, 0)、Offset(4, 0)、Offset(7, 0)に変えて３回回したら上手く動いたのですが、それ以降が止まってしまいますし、何か違う気がします。

よろしければ、お知恵を貸していただけないでしょうか。
４月からの繁忙期に、これが自動化できると大変助かります。
・ツリー全体表示
【75378】Re:コンボボックスのRowSourceを使ったフ...
発言  kanabun  - 14/3/14(金) 20:09 -
引用なし
パスワード
   ▼Domingo さん：

ComboBox2のリストは ComboBox1で選択があったら、
Columnプロパティで横方向リストをセットするようにしたらいかが？

------------------------------------------------
Option Explicit

Private Sub UserForm_Initialize()
　　ComboBox1.RowSource = "Sheet1!A2:A6"　 '適宜修正
　　
End Sub

Private Sub ComboBox1_Change()
　　Dim nRow&
　　Dim r As Range
　　nRow = ComboBox1.ListIndex + 1
　　Set r = Range(ComboBox1.RowSource).Item(nRow)
　　ComboBox2.Column = Range(r.Offset(, 1), r.End(xlToRight)).Value
End Sub
・ツリー全体表示
【75377】コンボボックスのRowSourceを使ったフォ...
質問  Domingo  - 14/3/14(金) 17:04 -
引用なし
パスワード
   初めて投稿します。Excel VBAで以下のことを行いたいと考えています。

データ参照用のシートに、世界の大陸と所属する国のデータを用意します。
縦方向に大陸が、横方向に各大陸の国が記載されています。

各大陸から１つの大陸を選択し、その大陸の中から１つの国を選択します。
その結果をExcelの別のシートに書き出すというものです。
これを行うため、ComboBoxのRowSource機能を用いて、データ参照用のシート上で
大陸の範囲を縦方向に特定し、その後国の範囲を横方向に特定する方法で行います。

問題は、最初に大陸を選択する時にドロップダウンボタンを押すと、縦方向にデータが表示され正常に選択もできるのですが、国で行うと横方向のため、横表示となり、選択すると常に一番左の国名しか選択できません。

どのようにすれば、国名も縦方向に表示され、国が１つだけ選択することができるでしょうか？お知恵を拝借したいと存じます。なお、以下にソースの一部を掲載します。また、Transpose関数を使って何かできないか考えましたが、良い考えが浮かびませんでした…

（大陸の選択に関する記述）
With Selection
　 column = .Rows.Count　　　　　　 '同上領域の列数を取得する
　 area = .Cells(1, 1).Address & ":" & .Cells(column, 1).Address '同上領域のアドレスを変数に
End With
　　
ComboBox1.RowSource = sht_name & "!" & area 'コンボボックスのリストのソースを設定する

（国の選択に関する記述）
With Selection
　　row = .Columns.Count　　　　　　　'同上領域の列数を取得する
　　area2 = .Cells(column, 2).Address & ":" & .Cells(column, row).Address '同上領域のアドレスを変数に
End With
　　
ComboBox2.RowSource = sht_name & "!" & area2 'コンボボックスのリストのソースを設定する
・ツリー全体表示
【75376】保存するたびにセキュリティの警告
質問  りった  - 14/3/14(金) 11:26 -
引用なし
パスワード
   お世話になっております。済みませんが、下記についてご教示頂きますようお願いします。
Excel2010でマクロを使うと、保存するたびにセキュリティの警告が出ます。
「保存時に個人情報を自動的に消してくれる機能が有って、マクロのファイルの場合はその機能が完全には動作しないから警告が出ている」という理解であってますでしょうか。

エラーメッセージ：
このドキュメントには、マクロ、ActiveXコントロール、XML拡張パックの情報、またはWebコンポーネントが含まれています。これらにはドキュメント検査機能で削除することができない個人情報が含まれる場合があります。

自分が作成したファイル以外は個人情報を自動的に消してくれる機能を生かしたまま、警告が出ないようにする方法が有りましたらご教示ください。
また、みなさんどのようにしているか、お勧めの対処等もご教示頂ければ幸いです。
・ツリー全体表示
【75375】Re:とある文字印刷時に表示させ印刷終了...
お礼  AAA  - 14/3/14(金) 7:58 -
引用なし
パスワード
   マナさん

できました。
最初に持ってくるんですね…
ﾌﾟﾘﾝﾄする前だと思い間に入れたりしていました。

ありがとうございました。
・ツリー全体表示
【75374】Re:とある文字印刷時に表示させ印刷終了...
発言  マナ  - 14/3/13(木) 23:10 -
引用なし
パスワード
   最初にRange("AI32").Value = "原本承認済"を実行したらよいと思います

Sub 複数印刷()
　　With Worksheets("Sheet1")
　　　　.Range("AI32").Value = "原本承認済"
　　　　.Range("AN19").Value = 1
　　　　.PrintOut
　　　　.Range("AN19").Value = 2
　　　　.PrintOut
　　　　.Range("AI32").Value = ""
　　End With
End Sub
・ツリー全体表示
【75373】とある文字印刷時に表示させ印刷終了後消...
質問  AAA  - 14/3/13(木) 20:00 -
引用なし
パスワード
   こんばんは。
少し行き詰っているのでご教授お願いします。

1枚の同じﾌｫｰﾏｯﾄに違う設備ごとで印刷を出しています。
　　AN　AO
21　1　 ○
22　2　 △
23　3　 □

C3にVLOOKUP関数でAN19列に1が入れば○、2が入れば△という式をいれてます。
それを、下記ﾏｸﾛで自動で変わり印刷をするようにしています。
Range("AN19").Select
ActiveCell.FormulaR1C1 = "1"
Range("AN19").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Range("AN19").Select
ActiveCell.FormulaR1C1 = "2"
Range("AN19").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True


ここからなんですが、これを印刷してる時に、
AI32のｾﾙに「原本承認済」という文字を入れたく、全ての印刷終了後には空欄に戻す作業をしたいのですが、ここまでは出来たのですが、
Range("AI32").Value = "原本承認済"
Worksheets("Sheet1").PrintOut
Range("AI32").Value = ""
をどう織り込んだらいいのかが分かりません。

Sub 複数印刷()

　　Range("AN19").Select
　　ActiveCell.FormulaR1C1 = "1"
　　Range("AN19").Select
　　ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
　　Range("AN19").Select
　　ActiveCell.FormulaR1C1 = "2"
　　Range("AN19").Select
　　ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
　　
　　Range("AI32").Value = "原本承認済"
　　Worksheets("Sheet1").PrintOut
　　Range("AI32").Value = ""
End Sub

とすると、空欄のもとの入ったものが出てきました・・・
全ての印刷が終わった時点で空欄にしたいのですが、ご教授の方よろしくお願いします。
・ツリー全体表示
【75372】Re:いつからいつまでを抽出
お礼  キョウコ  - 14/3/13(木) 17:45 -
引用なし
パスワード
   ▼kanabun さん：

>
>Sheet2の [P1:Q1]に書く見出しは Sheet1の[E1]と全く同じでないといけません。
>
ここが違っていました。
申し訳ありません><
修正したら理想通りに動いてくれました！

ありがとうございました！！
・ツリー全体表示
【75371】Re:いつからいつまでを抽出
発言  kanabun  - 14/3/13(木) 17:31 -
引用なし
パスワード
   手動でもうまくできないようだったら、
Sheet1のE列の日付データ(サンプルデータ)を 10データくらい、
ここに 提示してください。

たとえば、こんなの？

Sheet1　　　E列
1　　　　　売上日
2　　　　　　2/15
3　　　　　　3/1
4　　　　　　3/1
5　　　　　　3/3
6　　　　　　3/3
7　　　　　　3/5
8　　　　　　3/10
9　　　　　　3/20
10　　　　　 3/25
11　　　　　 4/1

Sheet2　検索開始日　2014/3/1
　　　　検索最終日　2014/3/20
・ツリー全体表示
【75370】Re:いつからいつまでを抽出
発言  kanabun  - 14/3/13(木) 17:13 -
引用なし
パスワード
   ▼キョウコ さん：

>早急なご返答ありがとうございました。
>しかし、載せていただいたマクロを実行しても
>コピーされるのは見出しだけです‥

AdvancedFilterは一般機能ですから、手作業でも実行することができます。

>'Sheet2の抽出条件をフィルタオプション用範囲[P1:Q2]にまとめる
>　　With ws2
>　　　　'Sheet1[E1]にある列見出し(「売上日」)をSheet2へコピー
>　　　　.[P1:Q1].Value = ws1.[E1].Value
>　　　　.[P2].Formula = ">=" & .[K3].Value2　'開始日付
>　　　　.[Q2].Formula = "<=" & .[M3].Value2　'終了日付
>　　End With

上のコードのように、「Sheet2」の[P1:Q2]範囲に 抽出条件を手作業で書き
Sheet6 をクリアして、Sheet6をアクティブにして AdvancedFilterによる
抽出コピーを実行して確認してみてください。

Sheet2の [P1:Q1]に書く見出しは Sheet1の[E1]と全く同じでないといけません。

抽出日付が 2014/3/1 〜 2014/3/20 だったら、
[P2]には　">=41699" と、
[Q2]には　"<=41718" と
書き込んでください。 この 41699 とか 41718 とかはシリアル値です。
マクロでは
> .[K3].Value2
> .[M3].Value2
で取得しています。
・ツリー全体表示
【75369】Re:いつからいつまでを抽出
質問  キョウコ  - 14/3/13(木) 16:53 -
引用なし
パスワード
   ▼kanabun さん：

早急なご返答ありがとうございました。
しかし、載せていただいたマクロを実行しても
コピーされるのは見出しだけです‥
・ツリー全体表示
【75368】Re:いつからいつまでを抽出
発言  kanabun  - 14/3/13(木) 16:52 -
引用なし
パスワード
   （補足2）
今回はある期間内の日付データの抽出ということで、一般機能のFilterを
使いましたが、単一の日付のときなら .Findメソッドが適当かというと、
Findメソッドで日付の検索はやらないほうがいいです。
なぜかというと、日付データのセルには「2010/1/6」のような「日付け型」
の値とともに、内部で計算するために「40512」というシリアル値も
格納されています。
Matchワークシート関数を使うと、セルの「40512」のようなシリアル値を
検索してくれます。
Findを使ったばあいは、シリアル値でなく「日付」を検索しようとします。
Findを使った日付の検索がよく失敗するのは、Findが文字列の検索をする
からです。日付の検索でも、セルの表示形式で検索値を文字列にして
検索しないとまずヒットしません。
ただ、Match関数だと検索範囲の先頭セルから検索していちばん最初に
マッチしたセルの位置を見つけてそれで終わり、です。なので、ある
範囲の中から同じ日付を複数個見つけようとするときは、
Find と FindNext のDo〜Loop でなく、フィルタを使ってください。
今回使ったAdvancedFilter でもいいし、AutoFilter でもいいです。
書き方は 以下の通り

（↓例は 2014/3/1 〜 2014/3/20 までの期間内データを抽出するばあい）
　範囲.AutoFilter 1, ">=" & CDate("2014/3/1"), xlAnd, _
　　　　　　　　　　 "<=" & CDate("2014/3/20")

（↓例は 2014/3/1 のレコードだけを抽出するばあい）
　範囲.AutoFilter 1, ">=" & CDate("2014/3/1"), xlAnd, _
　　　　　　　　　　 "<=" & CDate("2014/3/1")

一日だけでも、不等号を使い、「以上」「以下」と指定してやるのが、
ポイントです。一日だけだからといって、

　範囲.AutoFilter 1, CDate("2014/3/1")

とすると、失敗します。（たぶんFindのように文字列として検索する
からと思われます）
・ツリー全体表示
【75367】Re:いつからいつまでを抽出
発言  kanabun  - 14/3/13(木) 16:15 -
引用なし
パスワード
   期間のレコード抽出に使っているAdvancedFilter は
うまい日本語訳がなく 2003まではメニュ−[データ]-[フィルター]
のなかに [フィルターオプションの設定]としてありました。
2007以後は リボンの[データ]-[並べ替えとフィルター]のなかに
今度は [詳細設定]という名前であります。名前は変わりましたが、
表示されるダイアログは2003までのものと寸分違いがありません。
・ツリー全体表示
【75366】Re:いつからいつまでを抽出
発言  kanabun  - 14/3/13(木) 13:06 -
引用なし
パスワード
   ▼キョウコ さん：>こんにちわ。

>シート1のデータのE列の日付から（K3からM3まで）シート2の売上の日付のデータを抽出し
>シート6へ行ごとコピーしたいのです。

何年何月何日という単一の日付を見つけるには
ワークシート関数Matchを使います。

しかし、
> いつからいつまでを抽出
「期間を抽出」するにはフィルターを使います。


Sub Filter1()　'AdvancedFilter である期間を抽出コピー
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim ws3 As Worksheet
　　Set ws1 = Worksheets("Sheet1")
　　Set ws2 = Worksheets("Sheet2")
　　Set ws3 = Worksheets("Sheet6")
　　
　　'Sheet2の抽出条件をフィルタオプション用範囲[P1:Q2]にまとめる
　　With ws2
　　　　'Sheet1[E1]にある列見出し(「売上日」)をSheet2へコピー
　　　　.[P1:Q1].Value = ws1.[E1].Value
　　　　.[P2].Formula = ">=" & .[K3].Value2　'開始日付
　　　　.[Q2].Formula = "<=" & .[M3].Value2　'終了日付
　　End With
　　'フィルターオプション(AdvancedFilter)で抽出コピー
　　With ws3
　　　　.UsedRange.ClearContents
　　　　ws1.[A1].CurrentRegion.AdvancedFilter xlFilterCopy, _
　　　　　　CriteriaRange:=ws2.[P1:Q2], CopyToRange:=.[A1]
　　End With
End Sub
・ツリー全体表示
【75365】いつからいつまでを抽出
質問  キョウコ  - 14/3/13(木) 11:49 -
引用なし
パスワード
   こんにちわ。
早速ですが質問です。

シート2に売上と売上予定の日付が書かれているセルがあります。
（K3”2014/3/1”　L3”〜”　M3”2014/3/20”）売上
（K4”2014/3/21”　L4”〜”　M4”2014/3/31”）売上予定日

シート1に
売上データが記載されています。
A”顧客”　B”品名”　C”金額”　D”担当”　E”売上日or売上予定日”

シート1のデータのE列の日付から（K3からM3まで）シート2の売上の日付のデータを抽出し
シート6へ行ごとコピーしたいのです。

下記のマクロで
K3の日付のマクロを抽出することはできたのですが、
2014/3/1のデータしか引っ張れません。
どうにか試行錯誤しいろいろ試したのですが、
わかりそうもなくこちらで質問させていただきます。
よろしくお願い致します。


Dim ws1 As Range
Dim rng As Range
Dim myStr, ra, rr, myStr2

Sheet6.Cells.ClearContents　←ここでシート6の内容を消去

myStr = DateValue(Sheet2.Range("K3"))　←ここにM3も追加しK3〜M3としたい


Set ws1 = Sheet1.Cells
Set ws2 = Sheet6.Range("A1")
With ws1.Columns("E")

Set rng = .Find(What:=myStr, LookAt:=xlWhole, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox "ありません"
Else 'あったら
ra = rng.Address

Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng)
Loop While rng.Address <> ra
Set rng = Nothing
End If
End With

Set ws1 = Nothing
Set ws2 = Nothing
・ツリー全体表示
【75364】Re:エクセル貼り付け画像を切取り入力セ...
お礼  はや E-MAIL  - 14/3/10(月) 16:02 -
引用なし
パスワード
   ▼ichinose さん：
>こんばんは。
>
>>賞状をスキャナし画像をエクセルに貼りつけ、賞状の外側の鳳凰だけを残し
>>内側のセルに入力文章できるようにしたいと思います。
>
>貼り付けた賞状画像の上に図形のテキストボックス大きく配置する方法を
>試してみてください

ichinose さん

早速のご回答大変有難うございました。
成功いたしました。
感謝いたします。
・ツリー全体表示
【75363】Re:エクセル貼り付け画像を切取り入力セ...
発言  ichinose  - 14/3/9(日) 19:02 -
引用なし
パスワード
   こんばんは。

>賞状をスキャナし画像をエクセルに貼りつけ、賞状の外側の鳳凰だけを残し
>内側のセルに入力文章できるようにしたいと思います。

貼り付けた賞状画像の上に図形のテキストボックス大きく配置する方法を
試してみてください
・ツリー全体表示
【75362】エクセル貼り付け画像を切取り入力セルを...
質問  はや E-MAIL  - 14/3/8(土) 17:20 -
引用なし
パスワード
   賞状をスキャナし画像をエクセルに貼りつけ、賞状の外側の鳳凰だけを残し
内側のセルに入力文章できるようにしたいと思います。
・ツリー全体表示
【75361】Re:ＶＢＡ結合セルでのデーターソートに...
回答  あきな  - 14/2/23(日) 16:57 -
引用なし
パスワード
   次の手動での操作をマクロ記録した後、編集してみました。
　（１）結合されているA列をコピー
　（２）結合されていないC〜F列を選択　→　形式を選択して貼り付け　→　書式を選択してOK
　（３）並べ替え
　（４）C〜F列を選択して、結合解除

以下の条件で動作します。ご自分の環境に合わせて編集してください。

　１.データ範囲（Ａ１：Ｆ１１　/　１行目はタイトル）
　２.Ｊ２セルに並べ替えを行う列を指定（Ａ列で並べ替えるなら「Ａ１」と入力）
　３.このプロシージャでは、データを昇順に並べ替えるようになっています。
　　　降順にしたい場合は、Order:=xlAscendingを、Order:=xlDescending
　　　としてください。


Sub 結合セルでのソート()
　　With ActiveWorkbook.ActiveSheet
　　
　　　　Range("A2:A11").Copy
　　　　Range("C2:F11").PasteSpecial Paste:=xlPasteFormats
　　　　Application.CutCopyMode = False
　　
　　　　.Sort.SortFields.Clear
　　　　.Sort.SortFields.Add Key:=Range(Range("J2").Value), _
　　　　SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　End With

　　
　　With ActiveSheet.Sort
　　　　.SetRange Range("A2:H11")
　　　　.Header = xlNo
　　　　.MatchCase = False
　　　　.Orientation = xlTopToBottom
　　　　.SortMethod = xlPinYin
　　　　.Apply
　　End With
　　

　　Range("C2:F11").Select
　　Selection.UnMerge
　　Range("A1").Select

End Sub
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
352 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free