Excel VBA質問箱 IV

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

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


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

11 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82271】ありがとうございました。

Jaka - 24/2/11(日) 19:18 -


	引用なし

	パスワード

おおすげー
目安箱とかのボタンを押してもESETがはんのうしなくなった
ありがとうございました
これで今まで蓄積したエクセル、VBAコードをなくしましたが
これでとりあえず今のところ何とかなるかぁ？？？？

所でWindows11ってクソですね。
今度のThinkpad L　あれなんだっけ多分L560
第6世代のi5
500MのHDDをSSDに丸コピーして使ってますが
起動時間が、9分以上だったのが、今のところ1分以内になったことだけが
いいと思った
操作性は悪いし、何かやるにも輪ドライブとかに1度つなげないとダメとか
いろいろ不便
なんかMSのアカウント取りそこなったみたいでいろいろはじかれます
テンキー付きのノートパソキー位置と感覚がいまいちなじめないです。
今のところテンキーなんぞつけなきゃよかったかもと思ってます。
windowd7ときと同じことするのに工程が多くなった
では

・ツリー全体表示


	【82270】谷さんへ

Jaka - 24/1/31(水) 17:53 -


	引用なし

	パスワード

こんにちはひさしぶりです
Excel VBA質問箱 IV 内のホームボタンやら他
ホームから各ボタンを押すと、ESETが反応してしまい
閲覧できません。

Windows7の時はそれなりに閲覧できるときもあったんですが
Windows7のHDDが壊れてしまい、中古のWindows11のThinkpadL560だと
閲覧できません。

こんな感じに

このWebページには、感染したデバイスへのリモートアクセスを可能にしたり、デバイスから機密データを漏洩させたり、標的となったデバイスに害を与えたりする可能性がある危険なコンテンツが含まれる場合があります。
脅威: JS/Adware.Agent.DA アプリケーション

何とかならないもんでしょうか？

・ツリー全体表示


	【82269】Dior スーパーコピー

vogcopy.net - 24/1/29(月) 16:27 -


	引用なし

	パスワード

ディオール(DIOR)の2023年春メンズカプセルコレクションから新作スニーカーやジャケットが登場。vogcopy.net/brand-2-c0.html　Dior スーパーコピー 2023年1月6日(金)から1月22日(日)まで開催される東京・表参道「MICO JINGUMAE」の期間限定ストアで発売される。

ディオールを代表する「サドル(SADDLE)」バッグの新作は、vogcopycelinebad.on.omisenomikata.jp/ ERLのシグネチャーであるウェーブモチーフをキルティングで落とし込んだ。長さの調節が可能なブランドネーム入りのストラップが付属しており、ショルダーバッグでもクロスボディとしても使用することができる。

・ツリー全体表示


	【82268】Re:フォルダ内の画像の余白を削除

Trim - 24/1/25(木) 8:45 -


	引用なし

	パスワード

マナ様

ご返信ありがとうございます。
参考URLありがとうございます。

Powershellでも出来そうですね
フリーソフトが使えない環境ですので
手動でやっているのですが数が多いと
時間が掛かるのでVBAでできないものかと
考えておりました。

難しそうですねー

・ツリー全体表示


	【82267】Re:フォルダ内の画像の余白を削除

マナ - 24/1/24(水) 20:09 -


	引用なし

	パスワード

▼Trim さん：

こちらが参考にならないでしょうか。
ht tps://www.excel.studio-kazu.jp/kw/20221106151753.html
ht tps://www.excel.studio-kazu.jp/kw/20201225143843.html

・ツリー全体表示


	【82266】フォルダ内の画像の余白を削除

Trim - 24/1/24(水) 16:51 -


	引用なし

	パスワード

フォルダ内に幅3507ピクセル、高さ2480の画像ファイルが複数あります。

ペイントを開き、すべて選択した状態で
左90、上220移動する。
選択を解除して、下320、右190をカットする。
処理完了後、上書き保存。

上記の処理を行いたいのですが可能でしょうか？

コードを提示して頂けますと幸いです。
宜しくお願い致します。

・ツリー全体表示


	【82265】Re:別シートから一致する項目をすべて引...

迷える羊 - 24/1/24(水) 12:59 -


	引用なし

	パスワード

▼マナさん：
無事動かすことができました！！
ありがとうございました！

・ツリー全体表示


	【82264】Re:別シートから一致する項目をすべて引...

マナ - 24/1/23(火) 20:05 -


	引用なし

	パスワード

▼迷える羊さん：

Sub test3()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim r1 As Range, r2 As Range
　　Dim ws As Worksheet
　　Dim r3 As Range, r4 As Range
　　Dim c As Range, t As Range

　　Set ws1 = Sheets("Sheet1")
　　Set ws2 = Sheets("Sheet2")
　　Set r1 = ws1.Range("A13")
　　Set r2 = Union(ws2.Columns("H"), ws2.Columns("L"))
　　
　　Set ws = Worksheets.Add
　　Set r3 = ws.Range("A1")
　　Set r4 = ws.Range("C1")
　　Range(r1, r1.End(xlDown)).Copy r3
　　r2.Copy r4
　　
　　Set c = ws.Range("F1:F2")
　　 c(2).Formula = "=countif(A:A,D2)>0"
　　Set t = ws.Range("H1")
　　r4.CurrentRegion.AdvancedFilter xlFilterCopy, c, t
　　Set t = t.CurrentRegion
　　
　　With ws.Sort
　　　　.SortFields.Clear
　　　　.SortFields.Add2 _
　　　　　　　　Key:=t.Columns(2), _
　　　　　　　　CustomOrder:=WorksheetFunction.TextJoin(",", True, r3.CurrentRegion)
　　　　.SetRange t
　　　　.Header = xlYes
　　　　.Apply
　　End With

　　t.Columns(1).Copy r1.Offset(, 1)
　　
　　Application.DisplayAlerts = False
　　ws.Delete
　　Application.DisplayAlerts = True
　　Application.Goto r1, True
　　　　
End Sub

・ツリー全体表示


	【82263】Re:別シートから一致する項目をすべて引...

迷える羊 - 24/1/23(火) 17:10 -


	引用なし

	パスワード

▼マナさん：
ありがとうございます！
動きました！
が、大変申し訳ございません、
私が省略したばかりに。

それぞれのシートには項目名があり、
頂いたコードですと、それを消してしまいまして。
＞r.AdvancedFilter xlFilterCopy, , ws1.Cells(2)
ここが引っかかって来てるのかなとはあたりをつけたものの。

ので、以下正確にやりたいことを記載し直させてください！
散々コード記載頂いておりますのに申し訳ございません。
[sheet1]13行目～　　[sheet2]1行目～
名前(A列)　#(B列) 　#(H列)　名前(L列)
いちご　　　　　　　123　　いちご
みかん　　　　　　　234　　りんご
りんご　　　　　　　345　　みかん
ぶどう　　　　　　　456　　いちご
　　　　　　　　　　567　　りんご
　　　　　　　　　　678　　りんご

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

・ツリー全体表示


	【82262】Re:シートの中から必要なセルを複数取り...

マナ - 24/1/22(月) 23:40 -


	引用なし

	パスワード

▼かずこさん：

どんな並び替えなのか全くわかりません。
とりあえず、たたき台として。

Sub test()
　　Dim srtl As Object
　　Dim c As Range, k As String
　　Dim i As Long, r As Range, n As Long
　　
　　Set srtl = CreateObject("system.collections.sortedlist")
　　
　　For Each c In Columns(1).SpecialCells(xlCellTypeConstants)
　　　　If c.Value Like "?##-##-#" Then
　　　　　　k = c.Value
　　　　　　Set srtl(k) = c
　　　　Else
　　　　　　Set srtl(k) = Union(srtl(k), c)
　　　　End If
　　Next
　　
　　Worksheets.Add
　　For i = 0 To srtl.Count - 1
　　　　Set r = srtl.getbyindex(i)
　　　　If r.Count > 1 Then
　　　　　　Cells(1).Offset(n).Resize(r.Count).Value = r.Value
　　　　　　n = n + r.Count
　　　　End If
　　Next
　　　　
End Sub

・ツリー全体表示


	【82261】Re:シートの中から必要なセルを複数取り...

かずこ - 24/1/22(月) 23:13 -


	引用なし

	パスワード

▼マナさん：
>▼かずこさん：
>
>＞別シートに張り付けて並び替える
>
>並び替えのルールを教えてください

ご返信ありがとうございます。

並び替えが少し複雑で、説明が伝わりづらかったら申し訳ありません。
また、もし不可能でしたら全然構いません。

① レーン番号の頭3桁と、中2桁が一致しているものは同じ列にまとめて、下1桁の数字で下から上に昇順で並び替えます。(データ同士の間の空白は不要です)

② ①で作成したセルデータをひとまとまりとし、そこから又並び替えをします。
　レーン番号の頭3桁が同じ①は同じ行にまとめ、今度はレーン番号の真ん中2桁で左から昇順で並び替え　　ます。(間の空白は不要です)

③ ②で作成したひとかたまりを並び替えます。
　シートの上から下に、レーン番号の頭3桁を昇順で並び替えます。
　(左詰で、間に空白行をお願いします。)

以上よろしくお願いいたします。

・ツリー全体表示


	【82260】Re:シートの中から必要なセルを複数取り...

マナ - 24/1/22(月) 22:28 -


	引用なし

	パスワード

▼かずこさん：

＞別シートに張り付けて並び替える

並び替えのルールを教えてください

・ツリー全体表示


	【82259】Re:シートの中から必要なセルを複数取り...

かずこ - 24/1/22(月) 22:03 -


	引用なし

	パスワード

ご返信ありがとうございます。
1つのレーン番号と、レーン番号の真下にあるデータをセットとして扱いたいのですが、シート上では間に空白セルがなく連なっているパターンもあります。
よろしくお願いいたします。

・ツリー全体表示


	【82258】Re:シートの中から必要なセルを複数取り...

マナ - 24/1/22(月) 19:26 -


	引用なし

	パスワード

▼かずこさん：

>レーン番号があるセルから1つずつ下に参照していき、次に空白セルか別のレーン番号があるセルまでを参照するという条件分岐は作成可能でしょうか。

空白セルで分割するだけではだめということでしょうか。

・ツリー全体表示


	【82257】Re:別シートから一致する項目をすべて引...

マナ - 24/1/22(月) 19:00 -


	引用なし

	パスワード

▼迷える羊さん：

>Set d(c.Value) = CreateObject("system.collections.arraylist")
>がオートメーションエラーとなってしまいます、、

arraylistが使えない環境ということですね。
Excelの標準機能だけを使うようにしました。

Sub test2()
　　Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
　　Dim r As Range, c As Range

　　
　　　Set ws1 = Sheets("Sheet1")
　　　　Set ws2 = Sheets("Sheet2")
　　　　
　　　　ws1.Rows(1).Insert
　　　　ws1.Cells(1).Resize(, 2).Value = Array("t1", "t2")
　　　　ws2.Rows(1).Insert
　　　　ws2.Cells(1).Resize(, 2).Value = Array("t2", "t1")
　　　　
　　Set ws3 = Worksheets.Add
　　Set r = ws3.Cells(1)
　　Set c = ws3.Cells(5).Resize(2)
　　c(2).Formula = "=countif(" & ws1.Name & "!A:A,B2)>0"
　　
　　ws2.Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, c, r
　　Set r = r.CurrentRegion
　　
　　With r.Worksheet.Sort
　　　　.SortFields.Clear
　　　　.SortFields.Add2 _
　　　　　　Key:=r.Columns(2), _
　　　　　　CustomOrder:=WorksheetFunction.TextJoin(",", True, ws1.Columns(1))
　　　　.SetRange r
　　　　.Header = xlYes
　　　　.Apply
　　End With
　　
　　r.AdvancedFilter xlFilterCopy, , ws1.Cells(2)
　　
　　Application.DisplayAlerts = False
　　ws3.Delete
　　Application.DisplayAlerts = True
　　　　ws1.Rows(1).Delete
　　　　ws2.Rows(1).Delete
　　　　
　　　　ws1.Activate
　　　　
End Sub

・ツリー全体表示


	【82256】シートの中から必要なセルを複数取り出し...

かずこ - 24/1/22(月) 17:43 -


	引用なし

	パスワード

vba初心者です。よろしくお願いいたします。

下記は質問の為に作成した例になります。

-----------------------------------------
[Sheet1]

　　A列

1行目 918-01-1

2行目 MJIxPUS/
　　　RDXU2126441
　　　20　　　3.6
　　　TNK　　　 (E)

3行目

4行目 A14-03-2

5行目 MJIxPUS/

6行目 DKOU2405691

7行目 20　　　3.7

8行目 TNK　　　 (E)

9行目 3/1123

10行目

11行目

12行目 D13-03-2

13行目

-----------------------------------------

※1行目の 918-01-1 や12行目の D13-03-2 を下記便宜上「レーン番号」と書きます

※前段階でpdfデータをエクセルデータに変換しているため、同じデータでもセル数が異なっています。←ここがとても厄介です

※12行目のような下のセルが空白のレーン番号は必要ありません。※そのレーン番号のあるセルは削除していただいても構いません。

このようにデータがシート上にちりばめられており、上記の例で必要なデータは、1行目から2行目と4行目から9行目です。
(データはシート上にたくさんあり、4行目から9行目のようなパターンだとセル数が4～5と変動します)

ワイルドカード( "[ABC]##-##-#" と "###-##-#")などで頭のセルを見つけ、その下のセルをどこまで参照するかを条件分岐したいのですが、いいアイデアが思いつきません。

レーン番号があるセルから1つずつ下に参照していき、次に空白セルか別のレーン番号があるセルまでを参照するという条件分岐は作成可能でしょうか。

また、参照したセルを別シートに張り付けて順番に並べ替えるコードも教えていただけないでしょうか。

複雑になるかと思いますのでヒントだけでもいただけたら助かります。よろしくお願いいたします。

・ツリー全体表示


	【82255】Re:別シートから一致する項目をすべて引...

迷える羊 - 24/1/22(月) 15:23 -


	引用なし

	パスワード

▼マナさん：
ありがとうございます！
それらはうまく進むことができました！

ですが、
Set d(c.Value) = CreateObject("system.collections.arraylist")
がオートメーションエラーとなってしまいます、、
データをとても小さく数行にしてもエラーになってしまいます、

どうしたらよいか教えてほしいです、すみません。

・ツリー全体表示


	【82254】Re:別シートから一致する項目をすべて引...

マナ - 24/1/22(月) 12:58 -


	引用なし

	パスワード

▼迷える羊さん：

>>　　Dim d As Object, k
>kはVariantですかね？

はい。Variantです。

>また、
>>　　For Each k In d.keys
>>　　　　a.addrange dic(k)
>のdicでSubまたはFunctionが定義されていないと言われてしまいました。
>

ごめんなさい。動作確認しないで投稿していました。
dic(k)　でなく、d(k) でした。
　
　
　　　　　

・ツリー全体表示


	【82253】Re:別シートから一致する項目をすべて引...

迷える羊 - 24/1/22(月) 11:28 -


	引用なし

	パスワード

▼マナさん：

早々にご回答ありがとうございます！
>　　Dim d As Object, k
kはVariantですかね？

また、
>　　For Each k In d.keys
>　　　　a.addrange dic(k)
のdicでSubまたはFunctionが定義されていないと言われてしまいました。

当初ユーザーフォームに入れていたせいかと思い、
標準モジュールに移動したのですが、
同じくだめでした。

・ツリー全体表示


	【82252】Re:別シートから一致する項目をすべて引...

マナ - 24/1/21(日) 23:11 -


	引用なし

	パスワード

▼迷える羊さん：

Sub test()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim c As Range
　　Dim d As Object, k
　　Dim v, i As Long, s As String
　　Dim a As Object
　　
　　Set ws1 = Sheets("Sheet1")
　　Set ws2 = Sheets("Sheet2")
　　Set d = CreateObject("scripting.dictionary")
　　
　　For Each c In ws1.Columns(1).SpecialCells(xlCellTypeConstants)
　　　　Set d(c.Value) = CreateObject("system.collections.arraylist")
　　Next
　　
　　v = ws2.Cells(1).CurrentRegion.Value
　　For i = 1 To UBound(v)
　　　　s = v(i, 2)
　　　　If d.exists(s) Then d(s).Add v(i, 1)
　　Next
　　
　　Set a = CreateObject("system.collections.arraylist")
　　
　　For Each k In d.keys
　　　　a.addrange dic(k)
　　Next

　　ws1.Cells(2).Resize(a.Count).Value = Application.Transpose(a.toarray)
　　
End Sub

・ツリー全体表示


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

11 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free