Excel VBA質問箱 IV

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

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


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

56 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81359】同じ数字の項目に反映させたいです。

ゆめ

- 20/6/17(水) 17:42 -


	引用なし

	パスワード

配線をまとめるのに作った複数のシートがあります。
内容は番号・サイズ・配線の行先です。
ですが、全てのシートには配線の順番の為、順番がバラバラに入力しなければいけません。
かなりの数があるので、ひとつのシートに入力欄を作り、そこに入力するとその番号のサイズや行先を変えられる方法はありますでしょうか。
すみません。
宜しくお願いします。

・ツリー全体表示


	【81358】担当者を特定して、LOOPでメール作成。他...

カラメル - 20/6/15(月) 3:03 -


	引用なし

	パスワード

アウトルックで、エクセルにあるデータを基にメールを送るマクロを作成しています。

nameで定義されている課題の担当者ごとに課題をまとめて、担当者ごとにメールを送りたいです。
どのようなコードを書けばよろしいですか。
とても、わかりにくいかと思いますが、ぜひお助けください。
よろしくお願いいたします。

担当者ごとにLOOPでプログラムを実行したいです。

Dim objOutlook As Outlook.Application
　　Set objOutlook = New Outlook.Application
　　Dim objMail As Outlook.MailItem
　　Set objMail = objOutlook.CreateItem(olMailItem)
　　　　
　　'--- Excelワークシート ---'
　　Dim ws As Worksheet
　　Set ws = ThisWorkbook.Worksheets
　　Dim ws2 As Worksheet
　　Set ws2 = ThisWorkbook.Worksheets("担当者")
　　　　
　　'--- メールの内容を格納する変数 ---'
　　Dim toStr As String
　　Dim ccStr As String
　　Dim bccStr As String
　　Dim subjectStr As String
　　Dim bodyStr As String
　　Dim id As Long
　　Dim name As String
　　Dim i As Integer
　　Dim ID As Integer
　　Dim nittei As Date
　　Dim IDStr As String
　　Dim nitteiStr As String
　　
　　'For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
　　'ID = Cells(i, 4)
　　'nittei = Cells(i, 29)
　　'IDStr = Str(keyID)
　　'nitteiStr = Str(kigenbi)
　　'id = Cells(i, 22)
　　'name = Cells(i, 23)

　　'--- 件名の内容 ---'
　　subjectStr = "課題について"

　　
　　'--- 宛先の内容 ---'
　　'If ws2.Cells(2, 1) = tanto_id Then
　　　　'ws2.Cells(2, 2) = tanto_name
　　　　'ws2.Cells(2, 3).Value = toStr
　　'End If
　　　　
　　
　　'--- 本文の内容 ---'
　　 'For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

　　 bodyStr = tanto_name & "様" & "<br>" & "<br>" & "課題処理お願いいたします。"
　　 bodyStr = bodyStr + "<html><body><table border=1>"
　　 bodyStr = bodyStr + "<tr bgcolor =#191970><th>ID</th><th>課題名</th><th>種類</th><th>状態</th><th>日程</th></tr>"
　　 For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
　　　　 'Set objMail = objOutlook.CreateItem(olMailItem)
　　　　 If (Cells(i, 22) = tanto_id) Then
　　　　　　　　keyID = Cells(i, 4)
　　　　　　　　kigenbi = Cells(i, 29)
　　　　　　　　keyStr = Str(keyID)
　　　　　　　　kigenStr = Str(kigenbi)
　　　　　　　　bodyStr = bodyStr + "<tr style=color:red><td>"
　　　　　　　　bodyStr = bodyStr + idStr
　　　　　　　　bodyStr = bodyStr + "</td><td>"
　　　　　　　　bodyStr = bodyStr + Cells(i, 7)
　　　　　　　　bodyStr = bodyStr + "</td><td>"
　　　　　　　　bodyStr = bodyStr + Cells(i, 12)
　　　　　　　　bodyStr = bodyStr + "</td><td>"
　　　　　　　　bodyStr = bodyStr + Cells(i, 15)
　　　　　　　　bodyStr = bodyStr + "</td><td>"
　　　　　　　　bodyStr = bodyStr + nitteiStr
　　　　　　　　bodyStr = bodyStr + "</td></tr>"
　　　　　　　　
　　　　　　　　
　　　　 End If
　　Next i
　　bodyStr = bodyStr + "</table></body></html>"

　　'--- 条件を設定 ---'
　　objMail.To = toStr
　　objMail.CC = ccStr
　　objMail.BCC = bccStr
　　objMail.Subject = subjectStr
　　objMail.HTMLBody = bodyStr

　　'--- メールを表示 ---'
　　objMail.Display

End Sub

・ツリー全体表示


	【81357】Re:A1セルから1が入力されている最右のセ...

VN - 20/6/11(木) 19:18 -


	引用なし

	パスワード

▼マナさん：
>▼VN さん：
>
>こんな感じのほうが、わかりやすいです。
>
>Set b = Rows(1).Find(what:=a, SearchDirection:=xlPrevious)
>If Not b Is Nothing Then
>　　Range("A1", b).Font.Color = RGB(255, 0, 0)
>End If
マナ様
お世話になっております。
早速のご回答、ありがとうございます。

アドバイスのおかげで、無事にプログラムが動きました。
頂いた諸々のお知恵を使い、さらに研鑽させて頂きます。

引き続きよろしくお願いいたします。

・ツリー全体表示


	【81356】Re:A1セルから1が入力されている最右のセ...

マナ - 20/6/11(木) 19:03 -


	引用なし

	パスワード

▼VN さん：

こんな感じのほうが、わかりやすいです。

Set b = Rows(1).Find(what:=a, SearchDirection:=xlPrevious)
If Not b Is Nothing Then
　　Range("A1", b).Font.Color = RGB(255, 0, 0)
End If

・ツリー全体表示


	【81355】Re:A1セルから1が入力されている最右のセ...

マナ - 20/6/11(木) 18:56 -


	引用なし

	パスワード

▼VN さん：

b.Font.Color = RGB(255, 0, 0)

です

・ツリー全体表示


	【81354】A1セルから1が入力されている最右のセル...

VN - 20/6/11(木) 18:44 -


	引用なし

	パスワード

お世話になっております。
当方、VBA初心者です。

ネットでかなり調べたのですが対応方法が分からず、
こちらで質問をさせて頂ければ幸いです。

「A1セルから1が入力されている最右のセルまでを赤く塗る」
ために、下記のプログラムを組みました。

ところが、実行時エラー1004
アプリケーション定義またはオブジェクト定義のエラー
が表示されてしまい、動かない状態です。

おそらく、Findメソッドがうまく動いていないのかと推測しています。
どなたか、解決方法をご教授頂けますと幸いです。
お手数をお掛けします。

Sub 仮()
　　Dim a As Integer, b As Range
　　　　a = 1
　　Set b = Range("A1", Rows(1).Find(what:=a, SearchDirection:=xlPrevious))
　　　　Range(b).Font.Color = RGB(255, 0, 0)
End Sub

・ツリー全体表示


	【81353】Re:横並びのデータを5列毎に貼り付ける

猫ママ - 20/6/11(木) 13:22 -


	引用なし

	パスワード

アドバイスありがとうございます。
頑張ってみます。

▼マナさん：
>▼猫ママさん：
>
>>　　　　　　　　Worksheets("1").Cells(1 + 2, n).Value = 商品
>>　　　　　　　　Worksheets("1").Cells(2 + 2, n).Value = 名前
>
>行番号も列番号のように変数を使えばどうでしょうか。
>例えば、
>m = m + 2
>とするとか。

・ツリー全体表示


	【81352】Re:横並びのデータを5列毎に貼り付ける

マナ - 20/6/11(木) 12:40 -


	引用なし

	パスワード

▼猫ママさん：

>　　　　　　　　Worksheets("1").Cells(1 + 2, n).Value = 商品
>　　　　　　　　Worksheets("1").Cells(2 + 2, n).Value = 名前

行番号も列番号のように変数を使えばどうでしょうか。
例えば、
m = m + 2
とするとか。

・ツリー全体表示


	【81351】Re:横並びのデータを5列毎に貼り付ける

猫ママ - 20/6/11(木) 10:47 -


	引用なし

	パスワード

お世話になります。
Ifで入れてみたのですが、どうもうまく貼り付けません。
どう修正したらいいのでしょうか？
何度も申し訳ございません。

Sub オリジナル()
　　Dim r As Range
　　Dim j As Long, k As Long, i As Long
　　Dim 名前 As String, 商品 As String
　　Dim n As Long
　
　　 Set r = Worksheets("蒟蒻畑").Cells(1).CurrentRegion
　
　　 For j = 2 To r.Rows.Count
　　　　名前 = r.Cells(j, 1).Value
　　　　For k = 2 To r.Columns.Count
　　　　　　商品 = r.Cells(1, k)
　　　　　　For i = 1 To r.Cells(j, k)
　　　　　　　　
　　　　　　　　If n = 4 Then
　　　　　　　　n = 1
　　　　　　　　Worksheets("1").Cells(1 + 2, n).Value = 商品
　　　　　　　　Worksheets("1").Cells(2 + 2, n).Value = 名前
　　　　　　　　Else
　　　　　　　　n = n + 1
　　　　　　　　Worksheets("1").Cells(1, n).Value = 商品
　　　　　　　　Worksheets("1").Cells(2, n).Value = 名前
　　　　　　　　End If
　　　　　　
　　　　　　 Next
　　　　Next
　　Next

End Sub

▼マナさん：
>▼猫ママさん：
>
>>投稿No.81343の続きで、横並びになったデータを3列毎に改行して別シートに
>>貼り付けたいです。
>
>
>以下の部分で、貼り付け先を調整するとよいです。
>3列毎に改行なら、n＝4になったら、n=1とすれば
>列は、1→2→3→1→2→3…となります。
>同時に、行も、それぞれ、+2するとよいです。
>
>>　　　　　　　　n = n + 1
>>　　　　　　　　Worksheets("2").Cells(1, n).Value = 商品
>>　　　　　　　　Worksheets("2").Cells(2, n).Value = 名前
>
>
>>
>＾

・ツリー全体表示


	【81350】Re:横並びのデータを5列毎に貼り付ける

マナ - 20/6/10(水) 20:07 -


	引用なし

	パスワード

▼猫ママさん：

>投稿No.81343の続きで、横並びになったデータを3列毎に改行して別シートに
>貼り付けたいです。

以下の部分で、貼り付け先を調整するとよいです。
3列毎に改行なら、n＝4になったら、n=1とすれば
列は、1→2→3→1→2→3…となります。
同時に、行も、それぞれ、+2するとよいです。

>　　　　　　　　n = n + 1
>　　　　　　　　Worksheets("2").Cells(1, n).Value = 商品
>　　　　　　　　Worksheets("2").Cells(2, n).Value = 名前

>
＾

・ツリー全体表示


	【81349】横並びのデータを5列毎に貼り付ける

猫ママ - 20/6/10(水) 15:35 -


	引用なし

	パスワード

先日はありがとうございました。
投稿No.81343の続きで、横並びになったデータを3列毎に改行して別シートに
貼り付けたいです。

ぶどう　　　　白桃　　　　　オレンジ　もも　　　　もも　　　　　りんご　　　　　　マスカット
山田太郎山田太郎　山田太郎　山田太郎　　　　山田太郎　高橋一郎　高橋一郎　　　　

　　　　　　　　　　　　　　 ↓
ぶどう　　　　白桃　　　　　オレンジ　
山田太郎山田太郎　山田太郎
もも　　　　もも　　　　　りんご　　　　　　
山田太郎　　　　山田太郎　高橋一郎　
マスカット
高橋一郎

お手数お掛け致しますが、どうぞよろしくお願いいたします。

・ツリー全体表示


	【81348】Re:範囲指定ではないセルの一括コピーの...

よろずや - 20/6/9(火) 16:38 -


	引用なし

	パスワード

何をしたいのか今市ですが… Sub test() 　　Dim ary, e, p, sh1, sh2 　　Set sh1 = Worksheets(1) 　　Set sh2 = Worksheets(2) 　　ary = Array("A1=B2", "B3=A2", "C2=C1") 　　For Each e In ary 　　　　p = Split(e, "=") 　　　　sh1.Range(p(0)).Value = sh2.Range(p(1)).Value 　　Next End Sub

・ツリー全体表示


	【81347】範囲指定ではないセルの一括コピーの仕方...

初心者 - 20/6/9(火) 12:25 -


	引用なし

	パスワード

範囲指定(A1:C3)ではなく、
A1,B3,C2といった離れたセルを一括でB2,A2,C1セルに反映させる記述で悩んでいます。
A1,B3,C2の値全てをペースト先のそれぞれのセルに反映させたい訳ではなく、
A1=B2、B3=A2、C2=C1といった処理がしたいです。

Worksheets.Range("A1").Value = Worksheets.Range("B2").Value
Worksheets.Range("B3").Value = Worksheets.Range("A2").Value

といった感じで書けば想定通りには動くのですが、
行数が多くて汚く見えるのでもっと整理する方法はないでしょうか。

・ツリー全体表示


	【81346】Re:横並びの表　数字が入っているセルのみ

猫ママ - 20/6/9(火) 8:23 -


	引用なし

	パスワード

返信ありがとうございました！！！

バッチリです、これで業務がかなり改善出来ます。

もっとVBA勉強します。

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

▼マナさん：
>▼猫ママさん：
>
>配列を使わないほうが、わかりやすかったですね。
>
>Sub test2()
>　　Dim r As Range
>　　Dim j As Long, k As Long, i As Long
>　　Dim 名前 As String, 商品 As String
>　　Dim n As Long
>　　
>　　Set r = Worksheets("1").Cells(1).CurrentRegion
>　　
>　　For j = 2 To r.Rows.Count
>　　　　名前 = r.Cells(j, 1).Value
>　　　　For k = 2 To r.Columns.Count
>　　　　　　商品 = r.Cells(1, k).Value
>　　　　　　For i = 1 To r.Cells(j, k).Value
>　　　　　　　　n = n + 1
>　　　　　　　　Worksheets("2").Cells(1, n).Value = 商品
>　　　　　　　　Worksheets("2").Cells(2, n).Value = 名前
>　　　　　　Next
>　　　　Next
>　　Next
>
>End Sub

・ツリー全体表示


	【81345】Re:横並びの表　数字が入っているセルのみ

マナ - 20/6/8(月) 19:17 -


	引用なし

	パスワード

▼猫ママさん：

配列を使わないほうが、わかりやすかったですね。

Sub test2()
　　Dim r As Range
　　Dim j As Long, k As Long, i As Long
　　Dim 名前 As String, 商品 As String
　　Dim n As Long
　　
　　Set r = Worksheets("1").Cells(1).CurrentRegion
　　
　　For j = 2 To r.Rows.Count
　　　　名前 = r.Cells(j, 1).Value
　　　　For k = 2 To r.Columns.Count
　　　　　　商品 = r.Cells(1, k).Value
　　　　　　For i = 1 To r.Cells(j, k).Value
　　　　　　　　n = n + 1
　　　　　　　　Worksheets("2").Cells(1, n).Value = 商品
　　　　　　　　Worksheets("2").Cells(2, n).Value = 名前
　　　　　　Next
　　　　Next
　　Next

End Sub

・ツリー全体表示


	【81344】Re:横並びの表　数字が入っているセルのみ

マナ - 20/6/8(月) 19:03 -


	引用なし

	パスワード

▼猫ママさん：

>VBA初心者です

こんな感じが、わかりやすいかもしれません。

Sub test()
　　Dim w() As String
　　Dim r As Range
　　Dim j As Long, k As Long, i As Long
　　Dim 名前 As String, 商品 As String
　　Dim n As Long
　　
　　Set r = Cells(1).CurrentRegion
　　
　　For j = 2 To r.Rows.Count
　　　　名前 = r.Cells(j, 1).Value
　　　　For k = 2 To r.Columns.Count
　　　　　　商品 = r.Cells(1, k).Value
　　　　　　For i = 1 To r.Cells(j, k).Value
　　　　　　　　n = n + 1
　　　　　　　　ReDim Preserve w(1 To 2, 1 To n)
　　　　　　　　w(1, n) = 商品
　　　　　　　　w(2, n) = 名前
　　　　　　Next
　　　　Next
　　Next
　　
　　With Worksheets.Add
　　　　.Cells(1).Resize(2, n).Value = w
　　End With
　　
End Sub

・ツリー全体表示


	【81343】横並びの表　数字が入っているセルのみ

猫ママ - 20/6/8(月) 14:57 -


	引用なし

	パスワード

VBA初心者です、どうか教えてください。

　　　　　ぶどう　りんご　　白桃
稲川尚美　　　　　　1　　　　　　　　　　　1
蜂須　汐　　　　　　　　　　　2　　　　　　　1

商品名の下に件数が入っている表があります。件数が入っているセルだけ

ぶどう　　　　　　白桃　　　　　　りんご　　　　りんご　　　　　　白桃
稲川尚美　稲川尚美　蜂須　汐　　　　蜂須　汐　　蜂須　汐

商品名と名前を別シートに貼り付けたいです。2件以上の場合はその件数分連続で
貼り付けたいです。
お手数お掛け致しますがよろしくお願いいたします。

・ツリー全体表示


	【81342】Re:sumifのエラー

ms - 20/6/7(日) 13:43 -


	引用なし

	パスワード

▼BJ さん：
>ああ、
>Sumif 関数はセルを返すわけではないので、Set が出来ない。

ＢＪさん、返信ありがとうございました。
結果、setを使わないで一旦計算結果をシートに出力することにしました。

最後0.5乗するとオーバーフローを起こしてしまっているのですが、
それは改めて質問に挙げることにします。

・ツリー全体表示


	【81341】Re:エラーが表示されたらBeep音で知らせる

pollock - 20/6/5(金) 14:14 -


	引用なし

	パスワード

BJ様

教えて頂いた情報を元に、試行錯誤をしていました。
お陰様で、以下のコードによって「エラーが表示されたらBeep音で知らせる」が叶いました。
プロシージャ名には名前以上の意味と機能が備わっていたのですね。とても勉強になりました。ありがとうございました。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, i As Integer
　　If Not Intersect(Target, Range("AE17:AE116")) Is Nothing Then
　　　　If Target.Offset(, -7).Value = "***" Then
　　　　Beep
　　　　End If
　　End If
End Sub

・ツリー全体表示


	【81340】Re:sumifのエラー

BJ - 20/6/5(金) 13:14 -


	引用なし

	パスワード

ああ、
Sumif 関数はセルを返すわけではないので、Set が出来ない。

・ツリー全体表示


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

56 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free