Excel VBA質問箱 IV

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

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


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

40 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81686】Excelの一覧表の情報を、Wordテンプレー...

ExcelからWord - 21/3/22(月) 16:48 -


	引用なし

	パスワード

申し訳ありませんが、VBAで以下のことを対応したいと思うのですが、教えていただけますと助かります。

Excelの一覧表で管理している情報（行単位）を、
Wordテンプレート(同じフォルダに保存されている)の指定する部分に情報を差し込んでいき、情報（行）ごとに異なるWordファイルを作成したいと思います。

例）
Excelで管理している情報
　　A　　　B　　C　　　D
1　日付　時間　住所　名前
2　AAA　 AAA　 AAA　 AAA
3　BBB　 BBB　 BBB　 BBB

作成したいもの
Word ファイル1
日付AAA、　時間AAA　　住所AAA　　名前AAA

Word ファイル2
日付BBB　　時間BBB　　住所BBB　　名前BBB　
　

・ツリー全体表示


	【81685】Re:「名前を付けて保存」の保存場所の変更

γ - 21/3/21(日) 8:05 -


	引用なし

	パスワード

wb.SaveAs Filename:=x & " " & y & " " & z ではファイル名だけ指定し、フォルダは指定していません。この場合、カレントフォルダに保存されます。カレントフォルダは、イミディエイトウインドウで ?CurDir とすると判明します。それがマイドキュメントフォルダになっているのでしょう。どうすればよいか。 ThisWorkBookのPathを求めて、それを頭につければOKです。その際、"\"を忘れないようにしてください。 wb.Path & "\" & x & " " & y & " " & z に代えればよいでしょう。（その部分以外は確認していません。）

・ツリー全体表示


	【81684】「名前を付けて保存」の保存場所の変更

モリ - 21/3/21(日) 6:22 -


	引用なし

	パスワード

初心者で試行錯誤しているのですが、上手くいかず頭を抱えております。
「H2」が生年月日
「B3」が名字
「D3」が名前
となっており、「生年月日名字名前」というファイル名で名前を付けて保存するマクロを、見様見真似で作りました。

最初は、当ファイルと同じフォルダにどんどん保存されていたのですが、今はマイドキュメントフォルダに保存されるようになってしまいました。

元ファイルと同じフォルダを指定して保存するにはどうすればよいでしょうか。
お手数をおかけしますが、どなたかご教授お願いします。

Sub ファイル保存()

　　Dim wb As Workbook　　　'ワークブック
　　Dim ws As Worksheet　　 'ワークシート
　　Dim x As String　 'H2セル用のフォルダ名用
　　Dim y As String　 'B3セル用のファイル名用
　　Dim z As String　 'D3セル用のファイル名用

　　'自ワークブック
　　Set wb = ThisWorkbook
　　'アクティブシート
　　Set ws = ActiveSheet

　　'H2セルの値を変数に
　　x = ws.Range("H2").Value
　　'B3セルの値を変数に
　　y = ws.Range("B3").Value
　　'D3セルの値を変数に
　　z = ws.Range("D3").Value

　　wb.SaveAs Filename:=x & " " & y & " " & z

End Sub

・ツリー全体表示


	【81683】バーコード作成VBA

ak - 21/3/19(金) 10:49 -


	引用なし

	パスワード

下記を実行するとエラーが発生します。
セルを3つくらい選択時はエラーが発生しないのですが
10個以上選択し実行すると
rangeクラスのSpecial～のエラーがでます
原因わかりますでしょうか。。

Option Explicit
Function CHECKDIGIT(ByVal target As Range) As String
Dim strJAN As Integer
Dim i As Integer
Select Case Len(target)
Case 12, 13
i = (CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1)) + _
CInt(Mid(target, 8, 1)) + CInt(Mid(target, 10, 1)) + CInt(Mid(target, 12, 1))) * 3
i = i + CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) + _
CInt(Mid(target, 7, 1)) + CInt(Mid(target, 9, 1)) + CInt(Mid(target, 11, 1))
strJAN = Right(10 - CInt(Right(i, 1)), 1)
CHECKDIGIT = strJAN
Case 7, 8
i = (CInt(Mid(target, 1, 1)) + CInt(Mid(target, 3, 1)) + CInt(Mid(target, 5, 1)) _
+ CInt(Mid(target, 7, 1))) * 3
i = i + CInt(Mid(target, 2, 1)) + CInt(Mid(target, 4, 1)) + CInt(Mid(target, 6, 1))
strJAN = Right(10 - CInt(Right(i, 1)), 1)
CHECKDIGIT = strJAN
Case Else
Exit Function
End Select
End Function
Sub MYBARCODECREATE()
Application.ScreenUpdating = False
Dim myheadchar13, myleftodd13, mylefteven13, myrighteven13, myleftodd8, myrighteven8 As Variant
Dim c As Range
Dim mycode As String
Dim myhdch As String
Dim sh As Worksheet, shbar As Worksheet
Dim i, p, q, r, s, t, u, v, w, x, y, z As Integer
Dim h
myheadchar13 = Array("aaaaaa", "aababb", "aabbab", "aabbba", "abaabb", "abbaab", "abbbaa", "ababab", "ababba", "abbaba")
myleftodd13 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
mylefteven13 = Array("2122111", "2112211", "2211211", "2122221", "2211121", "2111221", "2222121", "2212221", "2221221", "2212111")
myrighteven13 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
myleftodd8 = Array("2221121", "2211221", "2212211", "2111121", "2122211", "2112221", "2121111", "2111211", "2112111", "2221211")
myrighteven8 = Array("1112212", "1122112", "1121122", "1222212", "1211122", "1221112", "1212222", "1222122", "1221222", "1112122")
i = 1
Set sh = ActiveSheet
For Each c In Selection
Select Case Len(c)
Case 8, 13
If CStr(Right(c, 1)) <> CHECKDIGIT(c) Then
c.Interior.Color = 16711680
MsgBox "CHECK DIGIT ERROR" & vbCrLf & c.Address(False, False)
i = i + 1
End If
If i > 1 Then
Exit Sub
End If
End Select
Next
If IMEStatus <> vbIMEModeOff Then
SendKeys "{kanji}"
End If
x = InputBox("何列右にバーコードを作成しますか？")
Worksheets.Add
ActiveSheet.Name = "mysh"
Set shbar = Worksheets("mysh")
Cells.Interior.Color = 16777215
Cells.ColumnWidth = 0.08
Rows("2:2").RowHeight = 15
Rows("3:3").RowHeight = 4.5
Rows("4:4").RowHeight = 4.5
Cells.Font.Size = 6
Range("Q3").NumberFormatLocal = "000000"
Range("BL3").NumberFormatLocal = "000000"
With Range("A3:K4")
.Merge
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
With Range("Q3:BD4")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
With Range("BL3:CY4")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
Range("M2:M3").Merge
Range("O2:O3").Merge
Range("BG2:BG3").Merge
Range("BI2:BI3").Merge
Range("DA2:DA3").Merge
Range("DC2:DC3").Merge
Rows("6:6").RowHeight = 15
Rows("7:7").RowHeight = 4.5
Rows("8:8").RowHeight = 4.5
Range("M6:M7").Merge
Range("O6:O7").Merge
Range("AS6:AS7").Merge
Range("AU6:AU7").Merge
Range("BY6:BY7").Merge
Range("CA6:CA7").Merge
With Range("Q7:AP8")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
With Range("AX7:BW8")
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ShrinkToFit = True
End With
Range("Q7").NumberFormatLocal = "0000"
Range("AX7").NumberFormatLocal = "0000"
sh.Activate
For Each c In Selection
If Len(c) = 12 Or Len(c) = 13 Then
mycode = "222222222222121"
myhdch = myheadchar13(Left(c, 1))
For s = 2 To 7
Select Case Mid(myhdch, s - 1, 1)
Case "a"
mycode = mycode & myleftodd13(CInt(Mid(c, s, 1)))
Case "b"
mycode = mycode & mylefteven13(CInt(Mid(c, s, 1)))
End Select
Next s
mycode = mycode & "21212"
For t = 8 To 12
mycode = mycode & myrighteven13(CInt(Mid(c, t, 1)))
Next t
mycode = mycode & myrighteven13(CInt(CHECKDIGIT(c)))
mycode = mycode & "121222222222222"
shbar.Range("A3").Value = Left(c, 1)
shbar.Range("Q3").Value = Mid(c, 2, 6)
shbar.Range("BL3").Value = Mid(c, 8, 5) & CHECKDIGIT(c)
For w = 1 To Len(mycode)
If Mid(mycode, w, 1) = 1 Then
shbar.Cells(2, w).Interior.Color = 0
End If
Next w
shbar.Range("A2:DO4").CopyPicture Appearance:=xlScreen, Format:=xlPicture
c.Offset(, x).PasteSpecial
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Height = c.Height - 4
.Width = c.Offset(0, x).Width - 4
.Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
.Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
End With
shbar.Cells.Interior.Color = 16777215
End If
If Len(c) = 7 Or Len(c) = 8 Then
mycode = "222222222222121"
For y = 1 To 4
mycode = mycode & myleftodd8(CInt(Mid(c, y, 1)))
Next y
mycode = mycode & "21212"
For z = 5 To 7
mycode = mycode & myrighteven8(CInt(Mid(c, z, 1)))
Next z
mycode = mycode & myrighteven8(CInt(CHECKDIGIT(c)))
mycode = mycode & "121222222222222"
For p = 1 To Len(mycode)
If Mid(mycode, p, 1) = 1 Then
shbar.Cells(6, p).Interior.Color = 0
End If
Next p
shbar.Range("Q7") = Left(c, 4)
shbar.Range("AX7") = Mid(c, 5, 3) & CHECKDIGIT(c)
shbar.Range("A6:CM8").CopyPicture Appearance:=xlScreen, Format:=xlPicture
c.Offset(, x).PasteSpecial
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Height = c.Height - 4
.Width = c.Offset(0, x).Width - 4
.Left = c.Offset(0, x).Left + (c.Offset(0, x).Width - .Width) / 2
.Top = c.Offset(0, x).Top + (c.Offset(0, x).Height - .Height) / 2
End With
shbar.Cells.Interior.Color = 16777215
End If
Next c
Application.DisplayAlerts = False
Worksheets("mysh").Delete
Application.DisplayAlerts = True
End Sub

・ツリー全体表示


	【81682】Re:変数のあるURLへのアクセス

γ - 21/3/17(水) 22:43 -


	引用なし

	パスワード

url = "h〇〇s　　〇〇〇.××co.jp/" & EIR & "/▲▲▲" と変数にいれて、 Debug.Print urlとしてイミディエイトウインドウに表示されるURLが正しいか確認して下さい。ブラウザーに入力することで、それが適正かどうか確認できますね。あなたしか確認はできません。

・ツリー全体表示


	【81681】変数のあるURLへのアクセス

Fujisan3776 - 21/3/17(水) 21:31 -


	引用なし

	パスワード

"h〇〇s　　〇〇〇.××co.jp/" & EIR & "/▲▲▲" 「EIR」という変数を含むURLにアクセスしようとしています。 " & EIR & "と記述したのですがアクセス不可です。どこがおかしいのか？分かる方、教えてください

・ツリー全体表示


	【81680】Re:WEB取り込みの際にエラーが出たり出な...

［名前なし］K.K - 21/3/12(金) 0:10 -


	引用なし

	パスワード

ありがとうございます。
安定してデーターを抜き出せるようになりました。

・ツリー全体表示


	【81679】Re:WEB取り込みの際にエラーが出たり出な...

γ - 21/3/9(火) 23:02 -


	引用なし

	パスワード

IE側のDOM構成処理が追いついていないことが原因と思われる。少々の待ち時間を入れている。 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '■■■追加 Sub 天気予報取り込み() 　　'Application.ScreenUpdating = False '更新状況を確認するためコメントアウト　　Dim ie As InternetExplorer 　　Dim Doc As HTMLDocument 　　Dim ObjTag As Object 　　Dim i As Long 　　Dim n As Long 　　Dim url As String 　　　　url = "//www.jma.go.jp/bosai/forecast/#area_type=class20s&area_code=2610000"'■要修正　　Set ie = CreateObject("InternetExplorer.Application") 　　'ie.Visible = True 　　ie.Visible = False 　　ie.navigate url 　　Do While ie.Busy Or ie.readyState <> READYSTATE_COMPLETE 　　　　DoEvents 　　Loop 　　Worksheets("天気").Select 　　Cells.ClearContents 　　Cells.NumberFormatLocal = "G/標準" 　　Set Doc = ie.document 　　Sleep 2000　　　　　　　'■■■■追加(2秒待つ）　　For i = 696 To 936 　　　　If Doc.all(i).tagName = "TD" Or Doc.all(i).tagName = "TH" Then 　　　　　　n = n + 1 　　　　　　Cells(Int((n - 1) / 8) + 1, (n - 1) Mod 8 + 1) = Doc.all(i).innerText 　　　　End If 　　Next i 　　Cells.EntireColumn.AutoFit 　　Cells.EntireRow.AutoFit 　　ie.Quit 　　ActiveWorkbook.Save 　　Application.ScreenUpdating = True End Sub

・ツリー全体表示


	【81678】Re:WEB取り込みの際にエラーが出たり出な...

K.K - 21/3/9(火) 22:03 -


	引用なし

	パスワード

そうなんですね。

//www.jma.go.jp/bosai/forecast/#area_type=class20s&area_code=2610000

で一度試してみていただけませんか。

URLはキッチリ書き込むとエラーかかるので、頭は省略しています。

・ツリー全体表示


	【81677】Re:WEB取り込みの際にエラーが出たり出な...

γ - 21/3/9(火) 13:00 -


	引用なし

	パスワード

どのサイトなのかという重要な手がかりを秘密にしているので、回答はつきにくいでしょう。無理にとは言いませんが、URLは示せないのですか？（その提示が無いと、解決する見込みは著しく低下します。　むろん確実に解決すると保証するわけにはいきませんが。）別に言い訳は不要で放置すればよいだけなのですが、こうした質疑に関する常識として持たれておくことも必要かと思い、敢えてメモします。 WEBサイトは個々で作りが違いますから、具体的なurlなしで想像できることには限りがあります。実際に動作することもあるようですから、コードの問題でも無いような気もしますが、仮にコードに問題があるとしても、基本的なコードの間違いでもない限り、実際に動作させて検証するのが確実ですし、手間もかかりません。色々な条件をあれこれ想定して研究してくれる奇特な回答者は少ないでしょう。こうした自動アクセスに抑制的なサイトもあります。一定期間に何度もアクセスがあったときに、不審アクセスとして特定の結果を返すサイトもあります。エラーになったときに、サイトから何が返されているかを検証することが解決の第一歩でしょう。回答するにあたって、そういうことを試すにもurlは必要です。

・ツリー全体表示


	【81676】WEB取り込みの際にエラーが出たり出なか...

K.K - 21/3/7(日) 11:43 -


	引用なし

	パスワード

天気予報のWEBサイトをエクセルに書き出す目的で作りましたが、
「実行時エラー'91 オブジェクト変数またはWITHブロック変数が設定されていません。」
が出たり、出なかったりします。

以下その構文ですが、

Sub 天気予報取り込み()

Application.ScreenUpdating = False

　　Dim ie As InternetExplorer
　　Dim Doc As HTMLDocument
　　Dim ObjTag As Object
　　Dim i As Long
　　Dim n As Long
　　
　　Set ie = CreateObject("InternetExplorer.Application")
　　ie.Visible = False
　　ie.navigate "WEBサイトのURL"
　　Do While ie.Busy Or ie.readyState < READYSTATE_COMPLETE
　　　　DoEvents
　　Loop
　　
　　Worksheets("天気").Select
　　Cells.ClearContents
　　Cells.NumberFormatLocal = "G/標準"
　　
　　
　　Set Doc = ie.document
　　For i = 696 To 936
　　　　If Doc.all(i).tagName = "TD" Or Doc.all(i).tagName = "TH" Then
　　　　　 n = n + 1
　　　　　　Cells(Int((n - 1) / 8) + 1, (n - 1) Mod 8 + 1) = Doc.all(i).innerText
　　　　End If
　　　 Next i
　　　　
　　Cells.EntireColumn.AutoFit
　　Cells.EntireRow.AutoFit
ie.Quit

　ActiveWorkbook.Save
　Application.ScreenUpdating = True

　
End Sub

一度マクロ実行すると、
If Doc.all(i).tagName = "TD" Or Doc.all(i).tagName = "TH" Then
の所で最初に書いたエラー(デバッグ?)がかかります。

そのまま「終了」を押してもう一度実行すると今度はちゃんと動いたりします。

考えられる異常が何かあればご示唆お願いします。
Windows10　excel2007です。
以前にこのファイルでクエリを使おうとしましたが、その名残がどこかでエラーを引き起こしているのでしょうか?

・ツリー全体表示


	【81675】Re:支店ごとの名簿とラベルを作るには

マナ - 21/3/5(金) 16:48 -


	引用なし

	パスワード

▼マングローブさん：

台帳データを使って、差し込み印刷（Word)で、リストを作成してはどうでしょうか。

・ツリー全体表示


	【81674】Re:支店ごとの名簿とラベルを作るには

マングローブ - 21/3/4(木) 9:27 -


	引用なし

	パスワード

▼γ さん：
下請けじゃない！対価を払え！おっしゃるとおりです・・・でも　ここまで手厳しい口調で返ってくるとはショックです。

私も気安く投稿したわけではありません。

前まで使っていたexcelバージョンでは「データ追跡機能付きテンプレートウィザード」機能やexcel単体でラベル作成ができましたがexcelのバージョンが上がったらそれらの機能がなくなってしまい、マイクロソフトのサイトでも私と同じ理由で困っている人の投稿があり、その回答が「ＶＢＡのサイトで質問してみたら？」というものだったのです。

それに加えさらに
いろんなサイトをみていますと私のようにＶＢＡはわからないけどこうしたいという投稿があり、それについて　こうしてみたら？と回答をいただいている人も多数いたので、何かしらヒントになるよなものが得られればそれをもとに一つ一つそれはどういう意味でどういうう動きなのか調べていけば加工できるかなと思ったのです。

ちょっと難しく考えすぎていて、各シートから転記する方法なら他のサイトでも公開されていたので、そちらで模索してみます。

というわけでこれ以上傷つきたくないのでレスは結構です。失礼しました。

・ツリー全体表示


	【81673】Re:支店ごとの名簿とラベルを作るには

γ - 21/3/3(水) 23:57 -


	引用なし

	パスワード

前半の方式なら、オートフィルタを使い、手作業でコピペすればよいのでは？
後半方式は内容が分かりませんでした。
行番号列番号も不明ですし、説明も要領を得ない適当な印象です。

>でもＶＢＡは扱ったことがなくて、そこを理解する時間のほうがかかってしまい、
>この作業を手作業で進めなければならない状況にありまして、投稿しました。

あなたのマクロのスキルアップに少しでも貢献できるということであれば、
不明点を質問して確認もするかも知れませんが、この状況では検討する
インセンティブは正直なところ湧きません。

こちらは別に下請け作業員ではありませんので、
ご自分でマクロを学習するつもりはなく、しかし、他人に依存するつもりなら、
正当な対価を払って外注されることをお薦めします。
（あくまで私見で、他の方は別のお考えをお持ちかも知れません。）

・ツリー全体表示


	【81672】支店ごとの名簿とラベルを作るには

マングローブ - 21/3/3(水) 17:24 -


	引用なし

	パスワード

支店と社員名例えて質問します。
支店ごとに支店名と社員名が入ったリストとラベルを作成しなければなりません。
ラベル作成は市販のラベルソフトの差し込み印刷を使います。差し込み印刷を使うために全支店と全社員名が入った１つのシート（以下台帳）を作成しないと差し込み印刷がうまくいかないのです。

リストはレイアウトが決まっているのでその決まったところに支店名と社員名を入れたいのです。

支店に例えているものは70から80個あります。
社員に例えているものは毎月変わり、人数も変わります。変わらない支店もあります。
毎月作り直さなければなりません。

台帳を作って各リストのテンプレートに転記するか、各リストを埋めて台帳を作るかどちらが作りやすいでしょうか。

いずれにしてもいろいろネットで探しましたがＶＢＡを組まないとできなさそうな気がしています。でもＶＢＡは扱ったことがなくてそこを理解する時間のほうがかかってしまいこの作業を手作業で進めなければならない状況にありまして、投稿しました。

先に台帳を作成する方法をとる場合　作りたいイメージは

１シートに全社員の名簿を作成します。実際には別の用途なのですが簡略化するために支店と社員にたとえて質問します。
１列目　　２列目　３列目　　　
支店番号　支店名　　　社員名
1001　　　Ａ支店　　あああ　あああ
1001　　　Ａ支店　　いいい　いい
・・略
1002　　　Ｂ支店　　ううう　ううう
・・略
といったように。

それを同じブック内のシート２からでも新規にbookを開いてでもいいのですが、
１シート１支店とし最初から作成している表の指定した場所に支店名を名前をセットし１bookにまとめたいのです。
例えばシート１が上記の台帳としたら、シート２をA支店、シート３をB支店というようにしてシート２移行は全部同じ書式の表を作成しておきます。

各シートの表に当てはめる
ヘッダー部が支店番号と支店名。その下に社員の名前を列挙

セルB3：支店番号　　ＳＥＱ：Ｃ６　セルD3：支店名
　　　　　　　　　　　　　　　　　セルD6から社員名

今Ａ4　１枚で２０人まで入る表のレイアウトです。ＳＥＱも１～２０まで固定で先にいれてあり、表の上部と下部に注意書きなどがあるのでそれは行ヘッターとして設定します。
しかし２０人を超える支店の場合、改ページと行ヘッダーとフッター部分の注釈は設定しているのでいいのですが、ＳＥＱを２１～社員分カウントーアップしてセットできるとありがたいです。

＜シートイメージ　表の罫線がうまくひけないので省きました＞
ａａａａａａａａａａａａａａａａ　←行へッターの注釈

1001　　Ａ社

　　　１　あああ　あああ
　　　２　いいい　いい

　　　20　こここ　こ　　

※1ｂｂｂｂｂｂｂｂｂｂｂ
※2ｃｃｃｃｃｃｃｃｃｃｃｃｃ　←行フッタの注釈

ここで改ページ

　　　21　さささ　ささ　
　　　22　しし　　ししし

すみません。どなたか教えていただけないでしょうか。

・ツリー全体表示


	【81671】Re:VBAコードの書き方

マナ - 21/2/21(日) 21:10 -


	引用なし

	パスワード

Sub test()
　　Dim r As Range
　　Dim c As Range
　
　　Sheet2.UsedRange.ClearContents
　　Sheet1.Cells(1).CurrentRegion.Copy Sheet2.Cells(1)
　
　　Set r = Sheet2.Cells(1).CurrentRegion
　　For Each c In Intersect(r, r.Offset(1, 1))
　　　　If -50 < c.Value And c.Value < 50 Then
　　　　　　c.ClearContents
　　　　End If
　　Next
　　
End Sub

・ツリー全体表示


	【81670】Re:チェックボックスのリンクするセルの...

あい - 21/2/20(土) 14:50 -


	引用なし

	パスワード

出来ました！

100シート近くのものを一括で設定できたので、本当に助かりました。
ありがとうございました。

・ツリー全体表示


	【81669】Re:チェックボックスのリンクするセルの...

γ - 21/2/20(土) 14:03 -


	引用なし

	パスワード

こういうことでしょうか？
Sub test()
　　Dim sh As Worksheet
　　Dim ch As CheckBox
　　For Each sh In Worksheets
　　　　For Each ch In sh.CheckBoxes
　　　　　　With ch
　　　　　　　　.Value = xlOn　 'または xlOff
　　　　　　　　.LinkedCell = ch.TopLeftCell.Offset(0, 4).Address
　　　　　　End With
　　　　Next
　　Next
End Sub

・ツリー全体表示


	【81668】チェックボックスのリンクするセルの一括...

あい - 21/2/20(土) 13:25 -


	引用なし

	パスワード

VBA超初心者です。
チェックボックスのリンクするセルを
コントロールの書式設定からではなく
VBAを使用して一括で指定したいです。

１つのシートに２０個ほどのチェックボックスがあり、
全てリンクするセルが設定されていない状態です。

リンクするセルの指定先→チェックボックスから右に４つ目のセル

同ブック内に、同様のシートが複数あり、
コマンドボタンを押すと他のシートも同じように
一括設定できるようなものを作成するコードを教えていただけないでしょうか？

アンケートの集計のために使用したいのです。
別の会社の方が作成したアンケートを使用するように言われたので、アンケート自体を集計しやすいものにすることが出来ず困っています。

説明下手で申し訳ありませんが、お力を貸していただけないでしょうか。
よろしくお願い致します。

・ツリー全体表示


	【81667】Re:VBAコードの書き方

マナ - 21/2/20(土) 10:10 -


	引用なし

	パスワード

▼s さん：

こんな感じの、繰り返し処理でどうですか

For gyo=2 to 4
　 For retu =2 to 4
　　　ここで、1セルずつ調べて転記
　 Next
Next

・ツリー全体表示


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

40 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free