Visual Basic（VBA）(20ページ目)

VBAマクロでデータ集計の結果を出すマクロの記載方法を教えてほしい、この結果が出た時にフォントの色を変更したいがその時のVBAコードの組み方を教えてほしい、このエラーメッセージの解決方法を知りたい等こちらに参考情報があるかもしれません。

回答数

気になる

稀に1円合いません？ Sheet1から金額と個数を貼り付ける下記コードで、金額を切り上げるコードを何

稀に1円合いません？ Sheet1から金額と個数を貼り付ける下記コードで、金額を切り上げるコードを何処に書けば良いかおわかりの方がいらっしゃいましたら教えてください。 Sub 金額転記() '対象シートを設定 Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") '最終行の取得 Dim Cmax1 As Long, Cmax2 As Long Cmax1 = Ws1.Range("A65536").End(xlUp).Row Cmax2 = Ws2.Range("A65536").End(xlUp).Row '変数設定 Dim Product_code As String, Master_code As String, Product_name As String Dim i As Long, j As Long, Product_price As Long 'Ws1のD列を取得 For i = 2 To Cmax1 Product_code = Ws1.Range("D" & i).Value 'Ws2のA列を取得 For j = 2 To Cmax2 Master_code = Ws2.Range("A" & j).Value 'Ws1のB列とWs2のA列をマッチング If Product_code = Master_code Then 'Ws2のC列とD列を取得 Product_name = Ws2.Range("C" & j).Value Product_price = Ws2.Range("D" & j).Value Exit For End If Next 'Ws1のG列とH列に出力 If Product_name <> "" Then '空白の初期化 Ws1.Range("G" & i).Value = Product_name Ws1.Range("H" & i).Value = Product_price Product_name = "" Product_price = 0 End If Next End Sub

質問日時: 2022/09/05 15:11 質問者: momo_2123

ベストアンサー

3

0
VBSで作成した相対パスのショートカットが他者と共有できません。

VBScriptについての質問です。社内のデータをクラウドで保存するようになり、HDDの時はエクスプローラーのショートカット（絶対パス）を使用していたのですが、クラウドのドライブでは絶対パスでショートカットを作成すると、個人の名前が入ってしまい。社内で共有できるショートカットを作成できなくなりました。そこで、相対パスのショートカットをVBSで作成しました。しかし、Aさん（作成者）が作成したショートカットをBさんがエクスプローラー上で、そのショートカットを確認することができません。エクスプローラー上でできる、隠しファイルの設定や、権限の設定などいじってみたのですが、いまだに確認することができていません。どなたかご存じの方がいらっしゃればご教授の方よろしくお願いします。

質問日時: 2022/09/05 11:20 質問者: でっく

解決済

1

1
Ｂ列の最終行までＡ列をオートフィル

画像のようにＢ列の最終行までＡ列をオートフィルしたいです。この処理をVBAで行いたいです。お詳しい方教えてください、宜しくお願いいたします。

質問日時: 2022/09/05 05:50 質問者: さわ子

ベストアンサー

2

1
Ａ列の最終行に合わせて範囲をコピー

Ａ列の最終行に合わせて範囲内をコピーしたいのですが、 Sub 最終行まで選択() Range(Range("A2"), Range("AF2").End(xlDown)).Copy End Sub このコードではA列が20行あって、AF列が30行あったら A2からAF30まで選択されます。 A列からAF列の範囲で他の列の行数に関係なく A列の最終行に合わせてコピーしたいです。今回の場合で言えばA2からAF20の範囲です。お詳しい方教えてください、宜しくお願いいたします。

質問日時: 2022/09/04 19:10 質問者: さわ子

ベストアンサー

2

0
関数を最終行までコピー

VBAで関数を最終行までコピーするコードですが数式が　=C2　の場合 Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=C2" で動作します。しかし数式が =TEXT(D2,"yyyy/m")　や =IF(O２<=0,"0",P２/O２)　の場合は、コンパイルエラー　修正候補　ステートメントの最後とエラーが出ます。どうすれば動作するのでしょうか？

質問日時: 2022/09/04 11:05 質問者: さわ子

ベストアンサー

3

0
別ブックの列同士の値が一致したときの処理

C:\Users\〇〇〇\Desktop\新しいフォルダー　内の「ブック1」の「貼付」シートのB列の値が「ブック2」の「参照」シートのAV列の値と同じ場合「ブック2」の「参照」シートのG列の値を「ブック1」の「貼付」シートのV列に返したいです。 B列の最終行まで取得したいです。 50000行以上あります。 VBAでなるべく処理の早い方法で実現できませんでしょうか？宜しくお願いいたします。

質問日時: 2022/09/03 08:27 質問者: さわ子

ベストアンサー

1

1
列を指定して文字を切り出し、他の列と結合

D列に00～09の2桁の数字が入力されています。これらの頭の"0"を取り、1桁の0～9のにしたいです。そしてC列とD列の値を結合したものをQ列に返したいです。 C列：スイカ D列：05 　　↓ C列：スイカ D列：5 Q列:スイカ５ D列は途中に空欄がある場合があります。最大500行としています。 VBAでできますでしょうか？宜しくお願いいたします。

質問日時: 2022/09/03 08:23 質問者: さわ子

ベストアンサー

5

0
データのある範囲を選択するVBAについて

いつもお世話になっております。この度、初心者知識でお恥ずかしながら下記のマクロを構築したのですが、データが入っていない場合は ★Range(Selection, Selection.End(xlDown)).SelectEnd(xlDown) の処理をせずその上の ■Range(Selection, Selection.End(xlToRight)).Select の処理で止め選択範囲をコピーしたくその際はどの様な構文になるのかご教示いただきたく質問させていただきました。 Sub 指定範囲選択() Sheets("Sheet3").Select Range("A1").Select Range(Selection, Selection.End(xlToRight)).Select 'A1～右端を選択(※Qセルまで) Selection.AutoFill Destination:=Range("A1:Q200"), Type:=xlFillDefault 'A1～Q200セルまでオートフィル Range("A1:Q200").Select 'C1セルを0以外でフィルター ActiveSheet.Range("A1").CurrentRegion.AutoFilter _ Field:=3, _ Criteria1:="<>0" Range("B2").Select ■Range(Selection, Selection.End(xlToRight)).Select ★Range(Selection, Selection.End(xlDown)).Select Selection.Copy End Sub またこの構築にするともっと短くできるなどございましたら重ねてよろしくお願い申し上げます。

質問日時: 2022/09/03 00:20 質問者: pino382

ベストアンサー

2

2
VBAが止まります。

Sub bookmerge() Dim b As Workbook '集計するブック Dim b1 As Workbook '集計先のブック Dim d '集計するブック内のシートのデータ数 Dim d1 '集計先のシートのデータ数 Workbooks.Add Set b1 = ActiveWorkbook For Each b In Workbooks If b.Name <> b1.Name Then Dim i As Long For i = 1 To b.Worksheets.Count d = b.Worksheets(i).Range("a" & Rows.Count).End(xlUp).Row d1 = b1.Worksheets(1).Range("a" & Rows.Count).End(xlUp).Row b.Worksheets(i).Rows("1:" & d).Copy b1.Worksheets(1).Range("a" & d1 + 1) Next End If Next End Sub

質問日時: 2022/09/02 14:51 質問者: 坊太郎

ベストアンサー

1

0
VBAが止まります。

フォルダ内の全てのエクセルデータを一つにまとめたいのですが、下記を実行すると、添付ファイルのメッセージが出て先に進みません。調べましたがよくわかりませんので、ご教示いただけませんでしょうか。画像の最上部の『'プログラム0｜変数設定の指定Option Explicit』が欄外にはみだしていて直せません、こちらが原因でしょうか。 ------------------------------------------------------- 'プログラム1｜プログラム開始 Sub GetExcelDataInFolder() 'プログラム2｜シート設定 Dim ws1 As Worksheet Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'プログラム3｜FileSystemObjectの設定 Dim fs As FileSystemObject Set fs = New FileSystemObject 'プログラム4｜対象フォルダを取得 Dim myfolder As Folder Set myfolder = fs.GetFolder(ThisWorkbook.Path) 'プログラム5｜対象フォルダ内の全ファイルを処理 Dim myfile As File For Each myfile In myfolder.Files 'プログラム6｜拡張子が「xlsx」のファイルのみを処理 If fs.GetExtensionName(myfile) = "xlsx" Then 'プログラム7｜フォルダ内のエクセルを開いてシートを設定 Dim wb As Workbook Set wb = Workbooks.Open(Filename:=myfile) Dim ws2 As Worksheet Set ws2 = wb.Worksheets(1) 'プログラム8｜開いたエクセルの最終行を取得 Dim cmax As Long cmax = ws2.Range("A65536").End(xlUp).Row Debug.Print myfile.Name & "のcmax=" & cmax 'プログラム9｜開いたエクセルのデータを転記 Dim i As Long For i = 2 To cmax Dim cmax1 As Long cmax1 = ws1.Range("A65536").End(xlUp).Row ws1.Range("A" & cmax1 + 1 & ":E" & cmax1 + 1).Value = ws2.Range("A" & i & ":E" & i).Value Next 'プログラム10｜エクセルを閉じる wb.Close 'プログラム11｜オブジェクト解放 Set ws2 = Nothing Set wb = Nothing End If Next 'プログラム12｜エクセルを保存 ThisWorkbook.Save 'プログラム13｜オブジェクト解放 Set myfolder = Nothing Set fs = Nothing 'プログラム14｜プログラム終了

質問日時: 2022/09/02 14:02 質問者: 坊太郎

ベストアンサー

2

0
outlook マクロが終了しません。

受信したメールの添付ファイルを特定のフォルダへ一括保存を行いたいのですが。下記を実行しますと、『添付ファイルを保存できません。操作を行うためのアクセス権がありません。』のメッセージが出て保存されません。修正方法ご存じの方、ご協力をお願いします。どの部分に何という構文を挿入すればよいのか。教えていただきたいです。 ------------------------------------------------------- Public Sub SaveAttachmentFiles() Dim oAccount As Account Dim folderINBOX As Folder Dim folderSUB As Folder Dim itemMail As Outlook.MailItem Dim strFilename As String Dim oAttachment As Attachment 'アカウント取得 Set oAccount = Application.Session.Accounts![taro_hanasaka@poppop.co.jp] '「受信トレイ」の取得 Set folderINBOX = oAccount.DeliveryStore.GetDefaultFolder(olFolderInbox) '「SUB」フォルダの取得 Set folderSUB = folderINBOX.Folders.Item("■注文残納期回答依頼書") 'For Eachのループでメール（MailItemオブジェクト）を取得 For Each itemMail In folderSUB.Items 'For Eachのループで添付ファイル（Attachmentオブジェクト）を取得 For Each oAttachment In itemMail.Attachments 'ファイル名（フルパス） '（保存フォルダは仮のものです） strFilename = "C:\Users\taro_hanasaka\Desktop\Private\納期回答\返信納期回答ホルダ" 'ディスクに保存する oAttachment.SaveAsFile strFilename Next Next End Sub

質問日時: 2022/09/02 11:14 質問者: 坊太郎

ベストアンサー

1

0
Excel vbaについて知恵もしくは、コード教えて下さいm(__)m ① 表にあるデータをコピー、

Excel vbaについて知恵もしくは、コード教えて下さいm(__)m ① 表にあるデータをコピー、隣シートのセル入力の最終行下へ貼り付け。ここまではマクロが出来ているのですが、表にあるデータから隣のシートへコピペする際に、同じものがないかを調べた上で貼り付けを行いたいのですが(同じものがあった場合はペーストしない)、どのような方法がありますか？一度貼り付けを行って、その後に重複削除する方法しかないですか？ ②G列の4行目〜セルに値が入ったら、エンター後、Worksheet_Changeが起動し、その行にそれぞれ値が入るようになっています。やりたい事は、G列　4行目セルに値が入ったら、3つ先下の何も入ってないセルに移動したい。(繰り返し行いたい) どのようなコードを書けばよろしいのでしょうか、、？ご教授のほどよろしくお願いします。

質問日時: 2022/09/01 23:57 質問者: srrrre

ベストアンサー

2

0
【VBA】写真の貼り付けコードがうまく機能しません。

VBAについての質問です。下記のように、結合したセルをダブルクリックした場合に、セルの大きさに合わせて画像を張り付けられるようなコードを作成したのですが、縦長の写真の場合うまくいきません。どのように修正したらよいでしょうか？詳しい方よろしくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'セル選択判定 '条件①結合セル②セル高さ100以上③セル幅100以上 If Target.MergeCells And Target.Height >= 100 And Target.Width >= 100 Then Cancel = True '画像挿入 Call PasteImage(Target) End If End Sub Public Sub PasteImage(ByVal Target As Range) Dim fileNm As String Dim shp As Object Dim rng As Range Dim myRange As Range Dim pWidth As Single Dim pHeight As Single Dim pLeft As Single Dim pTop As Single Dim mWidth As Integer Dim mHeight As Integer Dim rX As Single Dim rY As Single Dim objShape As Shape '画像選択 fileNm = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If fileNm = "False" Then MsgBox "画像を選択してください" Exit Sub End If 'セル内の画像削除 For Each shp In ActiveSheet.Pictures Set rng = Range(shp.TopLeftCell, shp.BottomRightCell) If Not (Intersect(rng, Selection) Is Nothing) Then shp.Delete End If Next mWidth = 2 '左右余白 mHeight = 15 '上下余白 Set myRange = Target Application.ScreenUpdating = False '表示位置の取得 With ActiveSheet.Pictures.Insert(fileNm).ShapeRange '左上隅の位置取得 pLeft = .Left pTop = .Top '一旦画像を削除する .Delete End With '画像サイズの取得 Set objShape = ActiveSheet.Shapes.AddPicture( _ Filename:=fileNm, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, _ Top:=0, _ Width:=0, _ Height:=0) With objShape .LockAspectRatio = msoTrue .ScaleHeight 1, msoTrue .ScaleWidth 1, msoTrue '画像サイズをセルの幅、高さに合わせる rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY - mHeight .Width = .Width - mWidth Else .Height = .Height - mHeight .Width = .Width * rX - mWidth End If pWidth = .Width pHeight = .Height '表示位置をセルの幅、高さに合わせる pLeft = pLeft + (myRange.Width - .Width) / 2 pTop = pTop + (myRange.Height - .Height) / 2 '一旦画像を削除する .Delete End With '画像の貼り付け Set objShape = ActiveSheet.Shapes.AddPicture( _ Filename:=fileNm, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=pLeft, _ Top:=pTop, _ Width:=pWidth, _ Height:=pHeight) Application.ScreenUpdating = True End Sub

質問日時: 2022/09/01 18:43 質問者: ni104ki

ベストアンサー

5

0
CODE関数のvbaバージョンか方法はありますか？

思い立ってアルファベットaなら1，ｂなら2と読み替えたい。ＣＯＤＥ関数なら96引けば出ますが、 WorksheetFunctionではCODEは使えません。 WorksheetFunction.Asc("a")はそのままaが戻ってきます。組み込む方法を教えてください。

質問日時: 2022/09/01 17:00 質問者: rexfan

ベストアンサー

5

0
セルが空白だった時の処理

AA列が空白だったとき、S列の値をAF列に返したいです。今までは関数を使用していましたがデータ数がとても多くなり、他の処理と含めVBAでまとめるためご質問しました。お詳しい方宜しくお願いします。

質問日時: 2022/09/01 07:07 質問者: さわ子

ベストアンサー

5

0
VBAが止まります。

皆さん、いつもありがとうございます。下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 asrs1をadrs1へ修正したりしましたが、改善されません。昨日まで動いたいたのですが。皆様、修正方法を教えていただけますでしdょうか。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか？", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display objMail.Save End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "下書きに保管しました" End Sub

質問日時: 2022/08/31 14:09 質問者: 坊太郎

ベストアンサー

3

0
【部分一致した行を含む8行をシートにコピーする方法】以下のような作業を行いたいのですが、どなたがコ

【部分一致した行を含む8行をシートにコピーする方法】以下のような作業を行いたいのですが、どなたがコードをご提示いただけませんでしょうか？シートＡ・・・集計シートＢ・・・一覧（同一ブック内）シートBのA列にはコードが並んでいます。この値を検索し、一致した場合、その行を含む8行をコピーしシートBへ貼り付けたい。よろしくお願いします！

質問日時: 2022/08/30 16:24 質問者: momo_2123

ベストアンサー

1

0
まとめシートから集計シートへA列のコードが一致したら1行コピーするマクロをネット上で見つけました。こ

まとめシートから集計シートへA列のコードが一致したら1行コピーするマクロをネット上で見つけました。このマクロで条件が一致したら10行コピーするへ変更するにはどのような修正を加えればよいでしょう？教えていただける方がいらっしゃいましたら宜しくお願い致します。 Sub Sample() Dim x As Variant Dim c As Range Dim cols As Long With Sheets("まとめ") 'シート１の列数取得 cols = .Cells(1, .Columns.Count).End(xlToLeft).Column End With With Sheets("集計") '最初に転記領域のクリア .Columns("B").Resize(, cols).ClearContents 'シート２のA1からA列のデータ最終行までのセルを１つずつ取り出す For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp)) 'その値でシート１のD列をMach検索 x = Application.Match(c.Value, Sheets("まとめ").Columns("B"), 0) If IsNumeric(x) Then 'もしあれば '１行分を転記 c.Offset(, 2).Resize(, cols).Value = Sheets("まとめ").Cells(x, "A").Resize(, cols).Value End If Next End With End Sub

質問日時: 2022/08/30 14:11 質問者: momo_2123

ベストアンサー

1

0
コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーし

コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーして集計シートへ縦に並べて貼り付けしたく、下記コードを書きましたが、実行結果は図のように100003の１行目しか貼り付けられません？イメージは図の赤枠へも貼付けができるようにしたいのですが、どのような修正を加えたらよいか教えていただけませんでしょうか。よろしくお願いいたします。 Sub 条件に合うデータを別シートへ() Dim Matome_Sht As Worksheet Dim Ws As Worksheet Dim i As Long Dim j As Long '転記先のシートを変数格納 Set Matome_Sht = Sheets("集計") '「まとめ」シート 1～最終行までループ For i = 1 To Matome_Sht.Cells(Rows.Count, 1).End(xlUp).Row '全シートをループ For Each Ws In Worksheets '「まとめ」シートのＡ列とシート名が一致したら If Matome_Sht.Cells(i, 1) = Ws.Name Then 'シートの1～最終行までループ For j = 1 To Ws.Cells(Rows.Count, 1).End(xlUp).Row 'シート名とＡ列が一致していたら「まとめ」シートに転記 If Ws.Name = Ws.Cells(j, 1) Then Ws.Select Ws.Range(Cells(j, 2), Cells(j, 12)).Copy Matome_Sht.Cells(i, 2) End If Next j End If Next Ws Next i End Sub

質問日時: 2022/08/29 23:46 質問者: momo_2123

ベストアンサー

1

0
以前シートを集めて1シートへ繋げる下記コードをご教授いただき作成しました。今回すでに集めてある「ま

以前シートを集めて1シートへ繋げる下記コードをご教授いただき作成しました。今回すでに集めてある「まとめ」シートのA列と一致する「集計」シートへ書き出したいのですが何処を変更すればよいかわかりません。ご教授いただけませんでしょうか。よろしくお願いいたします。 Sub sample() Dim keyCell As Range Dim i As Integer Set keyCell = Worksheets("集計").Range("A6")'集計表のコードセル Do While keyCell.Text <> "" For i = 2 To Sheets.Count With Worksheets(i) If LCase(StrConv(.Name, vbNarrow)) = LCase(StrConv(keyCell.Text, vbNarrow)) Then .Range("A6").Resize(400, .Range("A6").CurrentRegion.Columns.Count).Copy keyCell Exit For End If End With Next Set keyCell = keyCell.End(xlDown) Loop End Sub

質問日時: 2022/08/29 20:38 質問者: momo_2123

ベストアンサー

1

1
【マクロ】フォルダにファイルが１つも無い時に、ファイルがありませんとメッセージを表示する

下記のマクロをご覧ください Aフォルダにある複数のファイル【どんな種類でもOK】１回の実行で１個つず、Bフォルダへ移動するマクロです。動きます。このマクロにて、Aフォルダにファイルが１つも無い時に【ファイルがありません】とメッセージが表示されるようにしたいです。ご存じの方いましたら、宜しくお願いいたします【AフォルダからBフォルダへファイルを１つずつ移動するマクロ】 Sub フォルダAから時系列で1つずつフォルダBへ移動する() Dim f, fo, dt As Date, i As Long Dim fn As String, ex As String, tmp As String Dim pathB As String 'PDFfaxを最初に受信するフォルダを設定 Const pathA = "C:\Users\2020\Desktop\フォルダA" '太田個人作業フォルダを設定 pathB = "C:\Users\2020\Desktop\" & ChrW(12886) & " あいうえお\フォルダA" With CreateObject("Scripting.FileSystemObject") If Not (.FolderExists(pathA) And .FolderExists(pathB)) Then MsgBox "指定フォルダが存在しません" Exit Sub End If dt = Now + 1 For Each f In .getfolder(pathA).Files If f.DateLastModified < dt Then dt = f.DateLastModified Set fo = f End If Next f If Not fo Is Nothing Then ex = "." & .GetExtensionName(fo.Name) fn = Left(fo.Name, Len(fo.Name) - Len(ex)) tmp = .BuildPath(pathB, fn & ex) i = 1 While .FileExists(tmp) i = i + 1 tmp = .BuildPath(pathB, fn & "(" & i & ")" & ex) Wend .MoveFile fo.Path, tmp End If End With End Sub

質問日時: 2022/08/28 08:48 質問者: aoyama-reiko

ベストアンサー

4

0
指定文字を太字にするVBAを別シートのセルを指定する構文(改良について)

いつもお世話になっております。この度、下記のVBAの構文で指定文字を別シートを参照する形にしたい場合には、どの様な(構文)改良が必要かご教示をいただきたく質問させていただきました。 Sub 文言強調() Dim myReg As Object Dim m Range("E10").Replace "　", " ", xlPart Set myReg = CreateObject("VBScript.RegExp") myReg.Pattern = "(パソコン|レッツノート|Lenovo|HP)" myReg.Global = True With Range("E10") If myReg.test(.Value) Then For Each m In myReg.Execute(.Value) With .Characters(Start:=m.Firstindex + 1, Length:=m.Length).Font .Underline = xlUnderlineStyleDouble .Bold = True End With Next End If End With End Sub 指定文字の myReg.Pattern = "(パソコン|レッツノート|Lenovo|HP)" の構文を(例えば【Sheet2】の【D2】～下方向の末尾まで)に入力されているデータを条件にしたいと考えております。どうぞよろしくお願いいたします。

質問日時: 2022/08/27 22:11 質問者: pino382

ベストアンサー

6

0
VBAでエクセルをtxtに変換するとエクセルでカンマを含む文字数字がtxtでは「""」付にならないよ

下記コードでエクセルをtxtに変換するとカンマを含む文字数字が「””」付になってしまいます。カンマ「,」を含んでいても「””」付にならないような方法を教えていただけますか。 Private Sub CommandButton1_Click() Dim MyPath As String Dim MyName As String 'ファイルパス MyPath = ThisWorkbook.Path 'テキストファイルにつける名前 MyName = "リスト" '対象シート別ファイルへ複製 Sheets("Sheet1").Select Sheets("Sheet1").Copy 'テキストタブ区切りで保存 ActiveWorkbook.SaveAs Filename:=MyPath & "/" & MyName & ".txt", _ FileFormat:=xlText, CreateBackup:=False '複製したファイルを閉じる ActiveWorkbook.Close False End Sub

質問日時: 2022/08/27 12:17 質問者: ニックネーム船長

ベストアンサー

1

1
【困っています２】VBA 追加処理の記述を教えてください。

追加でVBA 追加処理の記述を教えてください。お世話になります。マクロの初心者です、稚拙な部分はご容赦ください。下記マクロを実行すると、メールが送れるようになりましたが送る前に確認をして送りたいのですが、構文のどの部分に追加で入れる記述を教えて頂けませんでしょうか。よろしくお願いいたします。リンク先　https://www.helpforest.com/excel/emv_sample/ex10 … ----------------------------------------------------------------------------------- SubSample() DimMacroBAsWorksheet'このブックのシート DimWb_DataAsWorkbook'1.分割元ブック DimWb_newAsWorkbook'分割データ保存ブック DimWsAsString'2.分割元シート名 DimPathAsString'3.分割データ保存先 DimC_GroupAsString'4.グループ対象列 DimGroupNameAsString'グループ名（ブック名） DimC_CopyAsString'5.コピーデータ右端列 DimYMDAsString'6.保存ブック日付の表示形式 DimPSWAsString'7.読み取りパスワード DimR_DataAsInteger'データの行番号 DimKoAsInteger'グループの件数 SetMacroB=ThisWorkbook.Worksheets(1)'このブックのシート SetWb_Data=Workbooks(MacroB.Range("C11").Value)'分割元のブック名 Ws=MacroB.Range("C12") Path=MacroB.Range("C13")&"\" C_Group=MacroB.Range("C14") C_Copy=MacroB.Range("C15") YMD=MacroB.Range("C16") PSW=MacroB.Range("C17") IfYMD=""Then YMD="" Else YMD=Format(Date,YMD) EndIf R_Data=2'データの開始行 Application.ScreenUpdating=False Do Wb_Data.Activate Worksheets(Ws).Range(Cells(1,1),Cells(1,C_Copy)).Copy'1行目の項目名コピー Workbooks.Add ActiveSheet.PasteRange("A1")'新規ブックに貼り付け SetWb_new=ActiveWorkbook Wb_Data.Activate GroupName=Cells(R_Data,C_Group) Ko=WorksheetFunction.CountIf(Columns(C_Group),GroupName)'グループの件数を算出 Range(Cells(R_Data,"A"),Cells(R_Data+Ko-1,C_Copy)).Copy'グループ件数分コピー Wb_new.Activate ActiveSheet.PasteRange("A2")'新規ブック項目の下に貼り付け ActiveSheet.Columns.AutoFit ActiveSheet.UsedRange.Borders.LineStyle=True Range("D2").Select ActiveWindow.FreezePanes=True DimmynameAsString'条件不明 IfActiveSheet.Range("A2")<>""Then myname=ActiveSheet.Range("A2") EndIf Wb_new.SaveAsFilename:=Path&GroupName&"注残納期回答依頼リスト"&YMD&".xlsx",_ Password:=PSW'指定したフォルダーに保存 Wb_new.Close R_Data=R_Data+Ko LoopWhileCells(R_Data,C_Group)<>"" MsgBox"完了！" Application.ScreenUpdating=True EndSub

質問日時: 2022/08/26 11:42 質問者: 坊太郎

ベストアンサー

2

0
VBA Shapesの座標からセル位置取得について教えてください

いつもお世話になります今、鉛直ラインを引いてそのShapeの属するセルアドレスを取得するステートメントを一行書いて、実行してみました　　 MsgBox ActiveSheet.Shapes("直線コネクタ 2").TopLeftCell.Address(False, False) 上側はうまく取れするのですが、さて下側は？　となりましたすみません、下側のアドレスを取得するものは有るのでしょうか？教えて頂けますか、よろしくお願い致します

質問日時: 2022/08/26 10:57 質問者: 公共ごま

ベストアンサー

1

0
VBAでoutlook365が起動しません。

VBAでoutlook365が起動しません。EXCELまたは、OUTLOOK設定がおかしいのでしょうか。メール一括作成のボタンを押しても『記載に誤りが無いことを確認しましたか？』『"送信完了しました』のメッセージは出るのですが、outlookが起動しませんし下書ホルダにも保存されません。 EXCELは他のマクロは動作しますし、Outlookはセキュリティ(トラストセンター)設定も有効です。どなたかご教示いただけますようお願いいたします。 EXCEL画面の画像と下記に対象の記述を記します。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか？", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "送信完了しました" End Sub

質問日時: 2022/08/25 13:31 質問者: 坊太郎

ベストアンサー

4

0
【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。

皆様、いつもお世話になっております。下記記述の構文追加し、下記①の処理を行いたいのですが、ご教示頂けませんでしょうか。未熟者ですので、問い合わせ等にお時間をいただくかもしれませんが、よろしくお願いいたします。可能でしたら前回ご協力いただきましたQchan1962様に続きをお願いします、他の方もよろしくお願いします。追加(記述を追加)したい処理内容。下記マクロで出来た全部のファイルを①のフォルダに保存する処理。 ① 「C:\Users\suzuko_atsushi\Desktop\Private\納期回答\納期回答保管」というフォルダに指定して保存。 ------------------------------------------------------------------------------------------------------- Sub Sample() Dim MacroB As Worksheet 'このブックのシート Dim Wb_Data As Workbook '1. 分割元ブック Dim Wb_new As Workbook '分割データ保存ブック Dim Ws As String '2. 分割元シート名 Dim Path As String '3. 分割データ保存先 Dim C_Group As String '4. グループ対象列 Dim GroupName As String 'グループ名（ブック名） Dim C_Copy As String '5. コピーデータ右端列 Dim YMD As String '6. 保存ブック日付の表示形式 Dim PSW As String '7. 読み取りパスワード Dim R_Data As Integer 'データの行番号 Dim Ko As Integer 'グループの件数 Set MacroB = ThisWorkbook.Worksheets(1) 'このブックのシート Set Wb_Data = Workbooks(MacroB.Range("C11").Value) '分割元のブック名 Ws = MacroB.Range("C12") Path = MacroB.Range("C13") & "\" C_Group = MacroB.Range("C14") C_Copy = MacroB.Range("C15") YMD = MacroB.Range("C16") PSW = MacroB.Range("C17") If YMD = "" Then YMD = "" Else YMD = Format(Date, YMD) End If R_Data = 2 'データの開始行 Application.ScreenUpdating = False Do Wb_Data.Activate Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy '1行目の項目名コピー Workbooks.Add ActiveSheet.Paste Range("A1") '新規ブックに貼り付け Set Wb_new = ActiveWorkbook Wb_Data.Activate GroupName = Cells(R_Data, C_Group) Ko = WorksheetFunction.CountIf(Columns(C_Group), GroupName) 'グループの件数を算出 Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy 'グループ件数分コピー Wb_new.Activate ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け ActiveSheet.Columns.AutoFit ActiveSheet.UsedRange.Borders.LineStyle = True Range("D2").Select ActiveWindow.FreezePanes = True Dim myname As String '条件不明 If ActiveSheet.Range("A2") <> "" Then myname = ActiveSheet.Range("A2") End If Wb_new.SaveAs Filename:=Path & " ■" & GroupName & " 注残納期回答依頼リスト" & YMD & ".xlsx", _ Password:=PSW '指定したフォルダーに保存 Wb_new.Close R_Data = R_Data + Ko Loop While Cells(R_Data, C_Group) <> "" MsgBox "完了！" Application.ScreenUpdating = True End Sub

質問日時: 2022/08/24 20:49 質問者: 坊太郎

ベストアンサー

2

0
エクセルのマクロで対象ごとにシート分けしてその内容をセルに書き込みたい

EXCELマクロ初心者です。マスターシート(Sheet1)にある表が「シート分け」ボタンを押されると「名前」列(A列)にある名前ごとにシート分けし、そのシート分けしたものに「野菜」列を表示する処理を追加思っています。 [名前] [野菜] 佐藤　　だいこん井上　　レタス佐藤　　にんじんこれがマスターシートの場合は [佐藤]というシートが作成され、作成されたシートのA1には「だいこん」、A2には「にんじん」と表示されるようにしたいです。色々検索をし、 ①マスターシートをフィルタ掛けする(AutoFilter処理) ②フィルタ掛けした結果のA列セルの名前を新しいシートに作成(Worksheets.Add処理) ③フィルタ掛けした結果を操作する(SpecialCell処理) ④フィルタ掛けした結果のB列を対象分(A1～個数分)を対象のシートのセルにA行に書き込むこのようにすればうまくいきそうな気はするのですが、最後の④の処理以降つまづいてしまっています。そもそもの①からのやり方がよくないからうまくいかないのか、④の構文が間違っているからうまくいかないのかでお手上げ状態です。 For I = 1 To xCol.Count Call Worksheets(Sheet1).Range("A1:B1").AutoFilter(1, CStr(xCol.Item(I))) '変数「xNSht」を初期化 Set xNSht = Nothing '変数「xNSht」にそれぞれのワークシート名を入れる(佐藤,井上) Set xNSht = Worksheets(CStr(xCol.Item(I))) 'シートが見つからない場合 If xNSht Is Nothing Then '新しくシートを挿入 Set xNSht = Worksheets.Add(, Sheets(Sheets.Count)) '新しくできたシート名を「Sheet1」のA2以降のセルの名前にする xNSht.Name = CStr(xCol.Item(I)) 'すでにシートがある場合 Else '一番後ろのシート後方に移動する xNSht.Move , Sheets(Sheets.Count) End If 　　 '絞り込んだセルの行のみ操作 Dim rowCounttest As Integer With xNSht.Range("A1").CurrentRegion '見出しを除いて表示している行をループ For Each a In .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).Rows rowCounttest = 1 Range("A" & rowCounttest).Value = a.Cells(1, 2) Next End With Next 一部変数の宣言部分などは省略をしていますが、①～④の処理はこのように入力しています。 '絞り込んだセルの行のみ操作部分が何か間違っているような感じもするのですが、お力添えいただければと思います。よろしくお願いいたします。

質問日時: 2022/08/24 13:23 質問者: doborn

ベストアンサー

9

0
VB.net

ウィンドウが2つ表示されており、1の方でFromAを開いており、2の方でCall FormA.Set() をするとFormAがNewされてしまいます。 FormAをNewすることなく2の方でFormA.SetDataを呼ぶにはどうしたらよいでしょうか。

質問日時: 2022/08/23 22:07 質問者: sige_417

解決済

2

0
集めたシートのシート名を変更したい。下記のコードでサブフォルダにあるファイルのSheet3を集めて

集めたシートのシート名を変更したい。下記のコードでサブフォルダにあるファイルのSheet3を集めています。しかし集めたシート名を元ファイル名の左から6文字にしたのですが解りません？「Worksheets(Worksheets.Count).Name = Left(.Name, 6)」を何処に置いたら良いか教えてください。よろしくお願いいたします。・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub シートコピー() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim FolderName As String '文字列を入れる変数として「FolderName」を使う Dim index As Integer '数字を入れる変数として「index」を使う Dim FileName As String '文字列を入れる変数として「FileName」を使う FolderName = Application.GetOpenFilename 'ダイアログを用いて選択したファイルのパスをFolderNameとする?@ If FolderName = "False" Then 'FolderNameが選択されていなければ作業を終了する Exit Sub End If '今のフォルダ名には選択したファイル名含まれているので、ファイル名の部分を切り取る作業。 index = InStrRev(FolderName, "\") 'フォルダ名部分の文字数をカウントする FolderName = Left(FolderName, index) ' カウントした文字数までの部分を切り取ってフォルダ名とする FileName = Dir(FolderName & "*xls*") ' フォルダの中に含まれるファイルを取り出す Do While FileName <> "" ' ファイルがなくなるまで繰り返す Workbooks.Open FolderName & FileName 'ファイルを開く Worksheets(3).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 'シートをコピーして取得 Workbooks(Workbooks.Count).Save Workbooks(Workbooks.Count).Close FileName = Dir() ' Loop End Sub

質問日時: 2022/08/23 10:38 質問者: momo_2123

ベストアンサー

6

1
パーソナルXLSBのfuctionを呼び出すと「Functionが定義されていません」のエラーになる

個人用マクロを作る練習で、あるサイトから下記サンプル①②をいれたのですが sub macroを実行するとコンパイルエラー「subまたはFunctionが定義されていません」となります。　エクセル2007です。 ①personal.XLSBの標準モジュール Function CalcTax(price As Long) As Double Dim d As Date Dim tax As Double ' 消費税が変わる基準日 d = #10/1/2019# If d > Date Then tax = 1.08 Else tax = 1.1 End If CalcTax = price * tax End Function ②BOOK1の標準モジュール Sub macro()　’消費税込み計算 Debug.Print (CalcTax(100))　　 End Sub 当初アドインで作ったのですが同じエラーで、アドイン設定に関係ない個人用マクロにしましたが同じエラーです。一旦保存して終了し再度開いてもエラーになります。 ①の中にsub macroを入れて実行すると正しく110と表示されます。何が不足していますでしょうか。

質問日時: 2022/08/22 22:51 質問者: rexfan

ベストアンサー

2

0
Excel VBA 大量のレコードからある列の重複数をカウントする方法？拡張編

ある列の重複数をカウントする作業があります。こちらのNo.13の回答で解決しているのですが、 https://oshiete.goo.ne.jp/qa/13027572.html 行数が増えてきたため、1シート(104万行)に収まらなくなりそうです。全く同じ処理を2シートにまたがって行う様に修正できないでしょうか？シート名は「重複①」「重複②」と考えていますが、プログラムの都合に合わせられます。 (例えばシート名の文頭が「重複～」のをすべて対象とできるなら万が一3シートを超える事があっても対応できるのに・・・というのは独り言です。)

質問日時: 2022/08/22 13:43 質問者: tanapyondai

解決済

7

0
シートをコピーする下記記述でダイアログを用いた記述がわかりません？( A = Dir(ThisWor

シートをコピーする下記記述でダイアログを用いた記述がわかりません？( A = Dir(ThisWorkbook.Path & FolderName "*") で構文エラーとなります？連結するにはどう書き換えたら良いかご教授いただけませんでしょうか？よろしくお願いいたします。 /////////////////////// Sub シートコピー() Application.DisplayAlerts = False Dim A Dim FolderName As String '文字列を入れる変数として「FolderName」を使う FolderName = Application.GetOpenFilename 'ダイアログを用いて選択したファイルのパスをFolderNameとする A = Dir(ThisWorkbook.Path & FolderName "*") 'フォルダ内のブック名を取得 Do While A <> "" 'ブックを開く Workbooks.Open ThisWorkbook.Path & "\FolderName\" & A With ActiveWorkbook 'シートをコピーして取得 .Worksheets("利用状況表（保育短時間）").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 'シート名をブック名に変更 ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = Left(.Name, 6) .Close False 'ブックを閉じる End With A = Dir() '次のブック名を取得 Loop End Sub

質問日時: 2022/08/22 12:26 質問者: momo_2123

ベストアンサー

4

0
Vba LongPtrについて教えてください

いつもお世話になります最近、Win32APIとWin64APIに共有できるようにPtrSafeを使うことにしましたいろいろな説明を見ましたが読解力が無い為、良く理解できずに全てのDeclare の後にPtrSafeを挿入し、ByVal hwnd As Longと ByVal hWndInsertAfter As LongをそれぞれLongPtrにしていますこれど良いのですか？また、フォーム最大化、最小化ボタンをつける場合のステートメントに使う変数、hWnd strClassName = "ThunderDFrame" '...ユーザフォームのクラス名を指定 hWnd = FindWindow(strClassName, Me.Caption) '...ウィンドウのハンドルを取得 lngNewLong = GetWindowLong(hWnd, GWL_STYLE) '...ウィンドウに関する情報を取得 rc = SetWindowLong(hWnd, GWL_STYLE, lngNewLong Or WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX) rc = DrawMenuBar(hWnd) そして、Excel画面を最前面に出すときのステートメントに使う変数、hWnd hWnd = FindWindow(vbNullString, MyBook & " - Excel") SetForegroundWindow hWnd '...最前面表示に対しても Dim hWnd As LongPtr　にしましたこれで良いのですか？半信半疑で使っています分かりました教えてください、よろしくお願い致します

質問日時: 2022/08/19 11:14 質問者: 公共ごま

ベストアンサー

2

0
VB.net

画像のようにチェックボックスで列の色が変わるようにしているのですが、コンボボックスだけ色が変わってくれません。コンボボックスの色を変える方法を教えてください

質問日時: 2022/08/18 19:21 質問者: katosige417

ベストアンサー

1

1
集計シートA列のコードと一致する右に並んだシート名（コード）の3行目から10行目をコピーして貼り付け

集計シートA列のコードと一致する右に並んだシート名（コード）の3行目から10行目をコピーして貼り付けたい。途中まで書いたコードで恐縮ですが修正点を教えていただけませんでしょうか？ ①A列コードと一致するシート名を検索して貼り付けできない ②データ部分3行目から10行目の指定ができない・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub TEST1() '2つ目のシートから最終シートまでループ For i = 2 To Sheets.Count 'データ部分のみを、集計シートにコピー With Sheets(i).Range("A3").CurrentRegion .Resize(.Rows.Count - 1).Offset(1, 0).Copy Sheets("集計").Cells (Rows.Count, "A").End(xlUp).Offset(1, 0) End With Next End Sub よろしくお願い致します。

質問日時: 2022/08/18 15:24 質問者: momo_2123

ベストアンサー

4

1
Excel VBA ユーザーフォーム内のラベルにテキストボックスの計算結果を出す方法

何度もすみません。。 https://oshiete.goo.ne.jp/qa/13099267.html で大変お世話になった者です。回答くださった皆様のおかげで、無事小計を出すことが出来ました。自分なりに調べ、次なる課題にチャレンジしているのですが早くも壁にぶつかり恐縮です。。 Textbox金額1～6まであり、1～3が仕入金額、4～6が売上金額となっています。その仕入と売上の利益と利益率をラベルに表示したいです。 label利益1に TextBox4ーTextBox1 label利益2に TextBox5ーTextBox2 label利益3に TextBox6ーTextBox3 label利益率1に label利益1/TextBox4,"#.0%" label利益率2に label利益2/TextBox5,"#.0%" label利益率3に label利益3/TextBox6,"#.0%" 何度もお手数をおかけして申し訳ございません。。どうぞよろしくお願いいたします。

質問日時: 2022/08/18 11:20 質問者: sonzaigakyousyuku

解決済

5

0
VB.net

画像のようにチェックボックスで列の色が変わるようにしているのですが、コンボボックスだけ色が変わってくれません。コンボボックスの色を変える方法を教えてください

質問日時: 2022/08/17 19:28 質問者: katosige417

解決済

1

0
Excel VBA ユーザーフォーム内のラベルにテキストボックスの小計を出す方法

お世話になります。初心者ですみません。。ユーザーフォームに数量・金額のテキストボックスがあります。数量のテキストボックスの小計は出すことが出来たのですが、金額の小計を出すことが出来ません。。色々なHPで見たところ金額のテキストボックスにあらかじめ TextBox金額1.Value = Format(TextBox金額1.Value, "##,##0") と入れているからなのかな？と思うのですが、この表示形式を崩さずに最下段の黒太字にある小計欄に金額小計を出したいです。よろしくお願いします。

質問日時: 2022/08/17 14:27 質問者: sonzaigakyousyuku

ベストアンサー

5

0
別シートのデータを参照して値を入れたい。まとめデータシートのC列D列の値を商品一覧シートのコードが

別シートのデータを参照して値を入れたい。まとめデータシートのC列D列の値を商品一覧シートのコードが一致した行のF列G列へ入れるため、下記のコードを書きました。まとめデータには、「りんご」、「ぶどう」、「いちご」しかありません。しかし実行すると商品一覧の「みかん」、「ばなな」に「りんご」の値が入ってしまいます。コードの修正箇所についてご教示いただけませんでしょうか？よろしくお願いいたします。 Sub 一覧へ転記() '対象シートを設定 Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("商品一覧") Set Ws2 = Worksheets("まとめデータ") '最終行の取得 Dim Cmax1 As Long, Cmax2 As Long Cmax1 = Ws1.Range("A65536").End(xlUp).Row Cmax2 = Ws2.Range("A65536").End(xlUp).Row '変数設定 Dim Product_code As String, Master_code As String, Product_name As String Dim i As Long, j As Long, Product_price As Long 'Ws1のD列を取得 For i = 2 To Cmax1 Product_code = Ws1.Range("D" & i).Value 'Ws2のA列を取得 For j = 2 To Cmax2 Master_code = Ws2.Range("A" & j).Value 'Ws1のB列とWs2のA列をマッチング If Product_code = Master_code Then 'Ws2のC列とD列を取得 Product_name = Ws2.Range("C" & j).Value Product_price = Ws2.Range("D" & j).Value Exit For End If Next Ws1のG列とH列に出力 Ws1.Range("G" & i).Value = Product_name Ws1.Range("H" & i).Value = Product_price Next End Sub

質問日時: 2022/08/17 13:20 質問者: momo_2123

ベストアンサー

7

0
vba 「インデックス有効範囲ではありません。」のメッセージの対処方法を教えてください。

Dim nendo As Integer FilePath = ActiveWorkbook.Path nendo = Range("k4").Value Workbooks("仕訳_支出_XXXX年度.xlsm").SaveAs Filename:=FilePath & "\仕訳_支出_" & nendo & "年度.xlsm" 上記の構文を実行すると最終行で「インデックスの有効範囲ではありません。」のエラーメッセージとなります。対処方法のご教授よろしくお願いします。

質問日時: 2022/08/16 20:19 質問者: ナカカズ

解決済

3

0
テーブルを配列に入れて、元のテーブルの行番号を取得したい

いつも大変お世話になっております。連日の投稿です。配列の初心者で、ここ数日かじるようになりました。下記コードの？？？？の部分をどうすれば行番号を取得できるのでしょうか？どなたかご教示お願い致します。根本的な間違いがあればご指摘頂くとありがたいです。 Dim a As Variant Dim w As Worksheet Set w = ThisWorkbook.Sheets("Sheet1") a = w.ListObjects("テーブル1").DataBodyRange For i = 1 To UBound(a) If a(i, 1) = Me.TextBox1.Text Then With UserForm1.ListView1.ListItems.Add .Text = Format(a(i, 1), "yyyy/mm/dd(aaa)") .SubItems(1) = a(i, 4) .SubItems(2) = a(i, 5) .SubItems(3) = a(i, 6) .SubItems(4) = Format(a(i, 7), "#,##0") .SubItems(5) = a(i, 10) .SubItems(6) = a(i, 15) .SubItems(7) =？？？？？　←　実際の元シートのセルの行番号を取得したい End With End If Next

質問日時: 2022/08/16 20:15 質問者: 太郎です

ベストアンサー

1

0
【前回の続きです、ご教示ください】VBAの記述方法がわかりません。

お世話になります。前回20220812 2128に投稿させていただき、回答をいただきトライしましたがうまくいきませんでした。私の情報が足らないか、理解できていない部分があるかもしれません。再度投稿させていただきます。どなたかご教示いただけませんでしょうか。(出来ればQchan1962様に続きをお願いします。) ●最初の質問は、下記のマクロ記述に変更を加えて、追加の作業を行いたいのですが、詳細は下記①の文面と添付ファイルの左半分をご覧ください。下記の②は頂いた回答です(添付ファイル左半分の文面の①～③作業部分を抜粋)、 ●追加の質問は、添付ファイルの右半分は頂いた回答で実行した結果のエラーメッセージです。の修正方法です。どうぞよろしくお願いいたします。 ------------------------------------------------------------ ① Sub Sample() Dim MacroB As Worksheet 'このブックのシート Dim Wb_Data As Workbook '1. 分割元ブック Dim Wb_new As Workbook '分割データ保存ブック Dim Ws As String '2. 分割元シート名 Dim Path As String '3. 分割データ保存先 Dim C_Group As String '4. グループ対象列 Dim C_Copy As String '5. コピーデータ右端列 Dim YMD As String '6. 保存ブック日付の表示形式 Dim PSW As String '7. 読み取りパスワード Dim R_Data As Integer 'データの行番号 Dim Ko As Integer 'グループの件数 Set MacroB = Workbooks("ex100010.xlsm").Worksheets(1) 'このブックのシート Set Wb_Data = Workbooks(MacroB.Range("C11").Value) '分割元のブック名 Ws = MacroB.Range("C12") Path = MacroB.Range("C13") & "¥" C_Group = MacroB.Range("C14") C_Copy = MacroB.Range("C15") YMD = MacroB.Range("C16") PSW = MacroB.Range("C17") If YMD = "" Then YMD = "" Else YMD = Format(Date, YMD) End If R_Data = 2 'データの開始行 Application.ScreenUpdating = False Do Wb_Data.Activate Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy '1行目の項目名コピー Workbooks.Add ActiveSheet.Paste Range("A1") '新規ブックに貼り付け Set Wb_new = ActiveWorkbook Wb_Data.Activate Ko = WorksheetFunction.CountIf(Columns(C_Group), Cells(R_Data, C_Group)) 'グループの件数を算出 Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy 'グループ件数分コピー Wb_new.Activate ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け Wb_new.SaveAs Filename:=Path & Cells(2, C_Group) & YMD & ".xlsx", _ Password:=PSW '指定したフォルダーに保存 Wb_new.Close R_Data = R_Data + Ko Loop While Cells(R_Data, C_Group) <> "" MsgBox "完了！" Application.ScreenUpdating = True End Sub ------------------------------------------------------------ ②頂いた回答(添付ファイルAの文面の①～③作業部分を抜粋) ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け '① ActiveSheet.Columns.AutoFit '② ActiveSheet.UsedRange.Borders.LineStyle = True '③ Dim myname As String　'条件不明 If ActiveSheet.Range("A2") <> "" Then myname = ActiveSheet.Range("A2") End If

質問日時: 2022/08/16 16:44 質問者: 坊太郎

ベストアンサー

2

0
vba スライサー

いつもお世話になっております下記のコードはスライサーを作成するコードですが、 Year("生年月日")ここのぶぶんですが西暦だけをスライサーに表示させることはできますでしょうか下記のコードはエラーになります。 With ThisWorkbook.SlicerCaches.Add(wS.ListObjects("xx"), Year("生年月日")) _ .Slicers.Add(wS, Top:=SlicerSete2.Top, _ Left:=SlicerSete2.Left, _ Width:=SlicerSete2.Width, _ Height:=SlicerSete2.Height)

質問日時: 2022/08/16 14:07 質問者: りんごプリン

ベストアンサー

1

1
Excel 関数またはマクロ、VBA

画像のようにデータを抽出する方法を教えてください。製品A,B,C、、ごとのデータは大抵1つ(数とその日付のひと組)だけです。いままでに2組あったことはないくらい稀てすが、あるかもしれないので、その行にある数字は全て抜きだすということです。 1度だけではなく、毎週このデータがきて、表のように抜きだす作業です。もしマクロかVBAかよく分からないですが必要ならば、組んだ経験がないので、わかりやすく教えていただければ助かりますよろしくお願いしますもしどうしても難しければ、日付は抜きにして、数だけの羅列でもかまいません(A 2 4 のように)

質問日時: 2022/08/16 11:15 質問者: lancru333

ベストアンサー

5

1
動きっぱなしです。止め方とプロシージャの間違いを教えて下さい！

VBA超初心者です。下記のプロシージャで実行したら、何かがループしている様子で、VBAのオブジェクトブラウザーがずっと動きっぱなしになっています。 Excelもおかしく、セルを選択すると同時に入力モードになって Ctrl+CやEscを連打して押し続けないとリボンの中が触れません。原因はこのプロシージャだと思うのですが、どこが間違っているのか、それによって何が起きてるのか、全く解りません。ループらしきものを止める事も出来ません。どなたか、止め方とプロシージャの間違いを教えて下さい。 Sub Macro1() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim saki As Long Dim moto As Long Set ws1 = ThisWorkbook.Worksheets("Sheet1") Workbooks.Open ThisWorkbook.Path & "\moto.xlsx" Set ws2 = ActiveWorkbook.Worksheets("Sheet1") For moto = 2 To 250 For saki = 5 To 54 If ws2.Range("A" & moto).Value = ws1.Range("B" & saki).Value Then Workbooks.Open ThisWorkbook.Path & "\moto.xlsx" If ws2.Range("C" & moto).Value = ws1.Range("D6").Value Then Range("D" & moto).Select Selection.Copy Windows("saki.xlsm").Activate Range("D" & saki).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End If 'この間にも同様なifのコードがあります If ws2.Range("C" & moto).Value = ws1.Range("Z6").Value Then Range("D" & moto).Select Selection.Copy Windows("saki.xlsm").Activate Range("Z" & saki).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End If End If Next Next For moto = 2 To 250 For saki = 5 To 44 If ws2.Range("A" & moto).Value = ws1.Range("AG" & saki).Value Then Workbooks.Open ThisWorkbook.Path & "\moto.xlsx" If ws2.Range("C" & moto).Value = ws1.Range("AI6").Value Then Range("D" & moto).Select Selection.Copy Windows("saki.xlsm").Activate Range("AI" & saki).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End If 'この間にも同様なifのコードがあります If ws2.Range("C" & moto).Value = ws1.Range("BE6").Value Then Range("D" & moto).Select Selection.Copy Windows("saki.xlsm").Activate Range("BE" & saki).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End If End If Next Next Windows("moto.xlsx").Activate ActiveWindow.Close False End Sub

質問日時: 2022/08/15 23:08 質問者: 1508_sio

解決済

5

0
重複したデータ(空白は除く)のVBA表記について

いつもお世話になっております。下記で質問した者です。 https://oshiete.goo.ne.jp/qa/13095593.html 質問カテゴリーをVBAに絞るため新たに質問させていただきました。 =SUMPRODUCT(1/COUNTIF(A1:A13,A1:A13&""))-1 上記の関数をVBAの構文で表すことは可能でしょうか？重ねて関数にお詳しい方いらっしゃいましたらご教示の程よろしくお願いいたします。

質問日時: 2022/08/15 12:41 質問者: pino382

ベストアンサー

5

0
A2セルの値が「100021_りんご01青森県」からInStrで「りんご」を抽出したい。セルの値が

A2セルの値が「100021_りんご01青森県」からInStrで「りんご」を抽出したい。セルの値が「100021_りんご01青森県」のような並びで「_」より右「01」より左の「りんご」を切り出したい。下記コードで「_」より右は切り出せますがこのコードを代えて切り出すことは可能でしょうか？ご指南のほどよろしくお願いいたします。・・・・・・・・・・・・・・ Dim N As Long Set cel = wbk.Worksheets("Sheet3").Cells(2, 1) N = InStr(cel, "_") cel.Offset(-1, 1) = Mid(cel, N + 1)

質問日時: 2022/08/15 09:42 質問者: momo_2123

ベストアンサー

5

0
サブフォルダ（データ）にある複数の.xlsxファイルのSheet3のA2セルの値で01から左側をB2

サブフォルダ（データ）にある複数の.xlsxファイルのSheet3のA2セルの値で01から左側をB2セルへコピーし、アンダーバーより左の値をB1セルへコピーし、右をC1セルへコピーしたい。下記コードを実行すると「Worksheets("Sheet3").Cells(2, 1).Select」でデバックになります。何処を修正したら良いか教えてください。よろしくお願いいたします。・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub コード商品切り出し() Dim FolderName As String '文字列を入れる変数として「FolderName」を使う Dim index As Integer '数字を入れる変数として「index」を使う Dim FileName As String '文字列を入れる変数として「FileName」を使う Dim N As Long Dim O As Long Dim P As Long FolderName = Application.GetOpenFilename 'ダイアログを用いて選択したファイルのパスをFolderNameとする① If FolderName = "False" Then 'FolderNameが選択されていなければ作業を終了する Exit Sub End If '今のフォルダ名には選択したファイル名含まれているので、ファイル名の部分を切り取る作業。 index = InStrRev(FolderName, "\") 'フォルダ名部分の文字数をカウントする FolderName = Left(FolderName, index) ' カウントした文字数までの部分を切り取ってフォルダ名とする FileName = Dir(FolderName & "*xlsx") ' フォルダの中に含まれるファイルを取り出す Do While FileName <> "" ' ファイルがなくなるまで繰り返す Workbooks.Open FolderName & FileName 'ファイルを開く Worksheets("Sheet3").Cells(2, 1).Select N = InStr(ActiveCell, "01") O = InStr(ActiveCell, "_") P = InStr(ActiveCell, "_") ActiveCell.Offset(0, 1) = Left(ActiveCell, N - 1) ActiveCell.Offset(-1, -1) = Left(ActiveCell, O - 1) ActiveCell.Offset(-1, 0) = Right(ActiveCell, P) Workbooks(Workbooks.Count).Save Workbooks(Workbooks.Count).Close FileName = Dir() ' Loop End Sub

質問日時: 2022/08/14 15:46 質問者: momo_2123

ベストアンサー

2

0
VBA 変数が思うように機能しません。ご教授願います。

下記コードで［大吉、中吉、小吉、凶］が出ません。［おみくじ0、1、2、3］となってしまいます。修正をお願いします。 Private Sub CommandButton1_Click() Dim i As Long Randomize '乱数系列初期化 i = Int(4 * Rnd) '０～3で乱数生成 Dim おみくじ0 As String Dim おみくじ1 As String Dim おみくじ2 As String Dim おみくじ3 As String Dim 運勢 As String おみくじ0 = "大吉" おみくじ1 = "中吉" おみくじ2 = "小吉" おみくじ3 = "凶" 運勢 = "おみくじ" & i MsgBox 運勢 End Sub

質問日時: 2022/08/14 13:50 質問者: ニックネーム船長

ベストアンサー

7

0

←前の結果
1
...
10
11
12
13
14
15
16
17
18
19
20
次の結果→

【プログラミング・Web制作】に関するカテゴリ

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

質問する（無料）

【Visual Basic（VBA）】に関するコラム/記事

弁護士が解説！あなたの声を行政に届ける「パブリックコメント」制度のすべて

社会に対する意見や不満、疑問。それを発信する場所は、SNSやブログ、そしてニュースサイトのコメント欄など多岐にわたる。教えて!gooでも「ヤフコメ民について」というタイトルのトピックがあり、この投稿の通り、...
弁護士が語る「合法と違法を分けるオンラインカジノのシンプルな線引き」

「お金を賭けたら違法です」ーーこう答えたのは富士見坂法律事務所の井上義之弁護士。オンラインカジノが違法となるかどうかの基準は、このように非常にシンプルである。しかし2025年にはいって、違法賭博事件が相次...
釣りと密漁の違いは？知らなかったでは済まされない？事前にできることは？

知らなかったでは済まされないのが法律の世界であるが、全てを知ってから何かをするには少々手間がかかるし、最悪始めることすらできずに終わってしまうこともあり得る。教えてgooでも「釣りと密漁の境目はどこです...
カスハラとクレームの違いは？カスハラの法的責任は？企業がとるべき対応は？

東京都が、客からの迷惑行為などを称した「カスタマーハラスメント」、いわゆる「カスハラ」の防止を目的とした条例を、全国で初めて成立させた。条例に罰則はなく、2025年4月1日から施行される。この動きは自治体...