Excel VBA質問箱 IV

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

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


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

29 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81911】Re:所定フォームへの流し込み

ackkn - 22/1/20(木) 10:32 -


	引用なし

	パスワード

マナ様
お返事が遅くなって申し訳ありませんでした。
昨年は時間が無く、手作業で終えたものですから、本当に申し訳ありませんでした。
今から動作確認をしますので、改めて結果のご報告をいたします。

・ツリー全体表示


	【81910】Re:数行おきに範囲指定してdelete

たろまる - 22/1/13(木) 0:32 -


	引用なし

	パスワード

▼マナさん：
ありがとうございます
助かりました！

・ツリー全体表示


	【81909】Re:数行おきに範囲指定してdelete

マナ - 22/1/12(水) 19:46 -


	引用なし

	パスワード

▼たろまるさん：

ws.Cells(Rows.Count, "J").End(xlUp).Row

J列でデータが入力されている最終行

・ツリー全体表示


	【81908】Re:数行おきに範囲指定してdelete

たろまる - 22/1/12(水) 0:31 -


	引用なし

	パスワード

▼マナさん：
ありがとうございます、無事動作しました。ちなみになのですが、これはどこの行まで行う等はどの部分で指定しているのでしょうか？
差し支えなければ教えて頂けると助かります。

・ツリー全体表示


	【81907】Re:数行おきに範囲指定してdelete

マナ - 22/1/11(火) 23:07 -


	引用なし

	パスワード

▼たろまるさん：

Option Explicit

Sub test()
　　Dim ws As Worksheet
Dim k As Long
Dim u As Range, r As Range

　　For Each ws In Worksheets
　　　　Set u = Nothing
　　　　For k = 8 To ws.Cells(Rows.Count, "J").End(xlUp).Row Step 3
　　　　　　Set r = ws.Cells(k, "J").Resize(2, 12)
　　　　　　If u Is Nothing Then
　　　　　　　　Set u = r
　　　　　　Else
　　　　　　　　Set u = Union(u, r)
　　　　　　End If
　　　　Next
　　　　If Not u Is Nothing Then u.ClearContents
　　Next

End Sub

・ツリー全体表示


	【81906】数行おきに範囲指定してdelete

たろまる - 22/1/11(火) 21:09 -


	引用なし

	パスワード

J列からU列までの間でまず8,9行目を選択、１行あけて11、12行目を選択これを繰り返して一括でセルの数値を削除する方法はありますでしょうか？複数sheetがあり、最終行がバラバラのためそこの判断も良い方法がありましたら教えて頂けると助かります。
初歩的なことかもしれませんが、何卒よろしくお願い致します。

・ツリー全体表示


	【81905】特定の日付の一ヶ月前に自動でメール送信

Ya - 22/1/11(火) 14:33 -


	引用なし

	パスワード

例えば部品の交換期限の管理をしてるExcelファイルで期限1ヶ月前になったらOutlookに自動でメール送信されるようにするなどといった事はVBA等を使用して可能なのでしょうか？

・ツリー全体表示


	【81904】Re:所定フォームへの流し込み

マナ - 22/1/9(日) 19:30 -


	引用なし

	パスワード

▼ackkn さん：
>行き詰まり、時間が無く困っています。
>毎年年末になると、荷主様から主要配送先への送り込み予定データが送られてきます。

i今更ですが、2022年末用に。
Sheet2の日付と曜日は、手作業で用意しておいてください。

Option Explicit

Sub test()
　　Dim r1 As Range, r2 As Range
　　Dim v, n As Long, w()
　　Dim dic As Object
　　Dim s As String, k As Long
　　Dim d As Long
　　
　　Set r1 = Sheet1.Range("A1").CurrentRegion
　　Set r1 = Intersect(r1, r1.Offset(1))
　　
　　Set r2 = Sheet2.UsedRange.Offset(2)
　　r2.ClearContents

　　v = WorksheetFunction.Sort(r1, 3)
　　n = UBound(v)
　　ReDim w(n * 2, 1 To r2.Columns.Count + 1)
　　Set dic = CreateObject("scripting.dictionary")
　　
　　For k = 1 To n
　　　　s = v(k, 3) & vbTab & v(k, 4)
　　　　If Not dic.exists(s) Then
　　　　　　dic(s) = dic.Count * 2
　　　　　　w(dic(s), 1) = v(k, 3)
　　　　　　w(dic(s), 2) = v(k, 4)
　　　　End If
　　　　d = (Day(v(k, 1)) - 13) * 2 + 3
　　　　w(dic(s), d) = v(k, 5)
　　　　w(dic(s), d + 1) = v(k, 6)
　　　　w(dic(s) + 1, d + 1) = v(k, 7)
　　Next
　　
　　r2.Resize(dic.Count * 2, UBound(w, 2)).Value = w
　　
End Sub

・ツリー全体表示


	【81903】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 14:22 -


	引用なし

	パスワード

▼マナさん：
Sheet1のB1がSharePointリストとの接続で作成していたテーブルデータだったため、"OData_日付"となっていました。
これを日付に変更したら、問題なくできました。

本当にありがとうございました。

・ツリー全体表示


	【81902】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/8(土) 14:17 -


	引用なし

	パスワード

▼えんさん：
>Sheet2のA列2行目以降が空白に置き換わってしまうのは変わらずです。

Sheet1のB1とSheet2のA1は、
どちらも「日付」という文字で間違いありませんか

・ツリー全体表示


	【81901】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 13:52 -


	引用なし

	パスワード

Sheet1の日付欄が時刻付きとなっていた為、日付のみに変更した所、testの方は数値が飛びました。しかし、Sheet2のA列2行目以降が空白に置き換わってしまうのは変わらずです。

私のミスで、錯綜させてしまい申し訳ございません

・ツリー全体表示


	【81900】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 13:46 -


	引用なし

	パスワード

▼マナさん：
Sheet1にマクロボタンを設置して作動させたのですが、testの方はA列2行目移行が空白に、B列2行目移行は今回は空欄でした。
test2の方は「型が一致しません」というエラーメッセージがでました。

Excel初心者のため、お手を煩わせてしまい申し訳ございません、、、

・ツリー全体表示


	【81899】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/8(土) 12:13 -


	引用なし

	パスワード

▼えんさん：

Sheet1に、

＞マクロボタンを設置

つまり、Sheet1が、アクティブな状態で実行する前提のマクロです。

・ツリー全体表示


	【81898】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 12:02 -


	引用なし

	パスワード

▼マナさん：
test()とtest2の両方

>Set r1 = Worksheets("Sheet1").Cells(2).CurrentRegion
>　　　　↓
>Set r1 = Cells(1).CurrentRegion
>Set r1 = Intersect(r1, r1.Offset(, 1))

に差し替えて試したのですが、まずtestの方はA列の2行目から下が空白になり、B列2行目からシリアル値(おそらく一年分)が入力されました。
つぎにtest２の方は

実行時エラー'1004'
「この選択は適切ではありません。コピー領域と貼り付け領域が同じサイズかつ同じ形状ではない場合は、それらの領域が重ならないようにしてください。

というエラーメッセージがでました。

・ツリー全体表示


	【81897】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/8(土) 10:03 -


	引用なし

	パスワード

▼えんさん：

Set r1 = Worksheets("Sheet1").Cells(2).CurrentRegion
　　　　↓
Set r1 = Cells(1).CurrentRegion
Set r1 = Intersect(r1, r1.Offset(, 1))

・ツリー全体表示


	【81896】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 9:52 -


	引用なし

	パスワード

▼マナさん：
いえ、sheetのタイトル名や説明書き、マクロボタンを設置しようと思っています。

・ツリー全体表示


	【81895】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/8(土) 9:14 -


	引用なし

	パスワード

▼えんさん：

Sheet1のA列はすべて空白でしょうか

・ツリー全体表示


	【81894】Re:Sheet1からSheet 2に日付を条件として...

えん - 22/1/8(土) 8:09 -


	引用なし

	パスワード

マナさん
ありがとうございます。

test1の方はSheet2のA列が2行目から下が消えてしまい、数値の入力はされてませんでした。
test2の方は型が一致しませんというエラーメッセージが表示されました。

VBA初心者で申し訳ないのですが、よろしくお願い致します。

・ツリー全体表示


	【81893】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/7(金) 22:28 -


	引用なし

	パスワード

▼えんさん：
Sub test2()
　　Dim r1 As Range, r2 As Range
　　Dim r As Range, m as Long

　　Set r1 = Worksheets("Sheet1").Cells(2).CurrentRegion
　　Set r2 = Worksheets("Sheet2").Cells(1).CurrentRegion
　　
　　For Each r In r1.Rows
　　　　m = Application.Match(r.Cells(1), r2.Rows(1), 0)
　　　　r.Copy
　　　　r2.Cells(1, m).PasteSpecial xlPasteValues, Transpose:=True
　　Next
　　Application.CutCopyMode = False

End Sub

・ツリー全体表示


	【81892】Re:Sheet1からSheet 2に日付を条件として...

マナ - 22/1/7(金) 20:33 -


	引用なし

	パスワード

▼えんさん：

Option Explicit

Sub test()
　　Dim r1 As Range, r2 As Range
　　Dim gyo, retu

　　Set r1 = Worksheets("Sheet1").Cells(2).CurrentRegion
　　Set r2 = Worksheets("Sheet2").Cells(1).CurrentRegion
　　Set r2 = r2.Offset(1).Resize(r1.Columns.Count - 1)
　　
　　gyo = Evaluate("row(2:" & r1.Columns.Count & ")")
　　retu = Application.Match(r2.Rows(0), r1.Columns(1), 0)

　　r2.Value = Application.Index(Application.Transpose(r1), gyo, retu)
　　On Error Resume Next
　　r2.SpecialCells(xlCellTypeConstants, xlErrors).ClearContents

End Sub

・ツリー全体表示


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

29 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free