Excel VBA質問箱 IV

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

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


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

56 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81364】Re:シート名が重複していたら連番を振る

OK - 20/6/23(火) 20:59 -


	引用なし

	パスワード

サンプルです。

Sub test()
Dim wb As Workbook
Dim basewsmei As String
Dim wsmei As String
Dim flg As Boolean
Dim newwsmei As String
Dim cnt As Integer
　Set wb = ActiveWorkbook
　 basewsmei = "Sheet"
　 If wschek(wb, basewsmei) = False Then
　　　newwsmei = basewsmei
　 Else
　　cnt = 0
　　Do Until flg = True
　　 cnt = cnt + 1
　　 newwsmei = basewsmei & "(" & Format(cnt, "0") & ")"
　　 If wschek(wb, newwsmei) = True Then
　　　　flg = False
　　 Else
　　　　flg = True
　　 End If
　　Loop
　End If
　wb.Worksheets.Add after:=wb.Worksheets(wb.Worksheets.Count)
　ActiveSheet.Name = newwsmei
　Set wb = Nothing
End Sub

Function wschek(ByVal wb As Workbook, wsmei As String) As Boolean
Dim myrng As Range
　Err.Clear
　On Error Resume Next
　Set myrng = wb.Worksheets(wsmei).Range("A1")
　If Err.Number <> 0 Then
　　 wschek = False '存在しない＝新規シート名として使える
　Else
　　 wschek = True '存在する＝新規シート名として使えない
　End If
　Set myrng = Nothing
　On Error GoTo 0
End Function

・ツリー全体表示


	【81363】Re:シート名が重複していたら連番を振る

OK - 20/6/23(火) 20:33 -


	引用なし

	パスワード

とくていの名前のシートは存在するか否かを判定する方法です。

ht tp://officetanaka.net/excel/vba/tips/tips10.htm

エラー処理を使った方法です。

Sub test()
Dim wsmei As String
Dim myrng As Range
　wsmei = "Sheet4"
　Err.Clear
　On Error Resume Next
　Set myrng = Worksheets(wsmei).Range("A1")
　If Err.Number <> 0 Then
　　 MsgBox wsmei & vbCrLf & "は存在しない"
　Else
　　 MsgBox wsmei & vbCrLf & "は存在する"
　End If
　Set myrng = Nothing
　On Error GoTo 0
End Sub

これらを改変して指定の名前のシートが存在しなくなるまでループ処理
するようにすればいいと思います。

・ツリー全体表示


	【81362】シート名が重複していたら連番を振る

VBAビギナー - 20/6/23(火) 11:06 -


	引用なし

	パスワード

お世話になります。
VBA初心者です。

CSVファイルから申込書へ転記し、
申込書のシート名にセルの値を追記しています。

ActiveSheet.Name = "txt_" & WS.Range("A1")

"A1"を追記した時に既に同一名のシートが存在した場合はエラーになります。
シート名重複のエラーを出さずにsheet(1)、sheet(2)といった感じで
出力する仕組みを入れたいです。

どなたかご教授お願いいたします。

・ツリー全体表示


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

ゆめ

- 20/6/17(水) 21:57 -


	引用なし

	パスワード

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

間違えた質問でしたらすみませんでした。
マクロで処理ができると早いのかと思い質問してしまって。
VLOOKUP関数を調べてやってみます。
教えていただきありがとうございます。

・ツリー全体表示


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

マナ - 20/6/17(水) 18:24 -


	引用なし

	パスワード

▼ゆめさん：

>かなりの数があるので、ひとつのシートに入力欄を作り、そこに入力するとその番号のサイズや行先を変えられる方法はありますでしょうか。

VLOOKUP関数が使えないでしょうか。

ここは、ExcelのVBA（マクロ）に関する質問掲示板です。
もし、関数や一般操作については、
他所で質問されると、より適切な回答が得られると思います。

・ツリー全体表示


	【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

・ツリー全体表示


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

56 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free