Visual Basic

全22553件中1~20件表示
  • 報酬付き

    VBA 類似処理の件数を同様にする方法について

    ExcelVBAの初歩的な質問です。 【質問内容】 [CheckAcolumnBrank]と[CheckBcolumnBrank]の処理を行った際に、[CheckBcolumnBrank]の結果が[CheckAcolumnBrank]の結果と行数が異なるため(5行ほど多く処理されてしまいます)、[CheckAcolumnBrank]の行数に合わせるコードを知りたいです。 ご見識のある方からの、お知恵の拝借をいただきたく、よろしくお願い申し上げます。 【前提条件】 1.シート1のA5からJ500までの範囲のセルに値が入力されています(空欄セルが不規則にあります)。 2.レコード数は10行程度から450行程度です。 3.A列のセルに値が入っていない場合は、1つ上のセルの値をコピーする挙動です。 4.B列についても、A列と同じ挙動をさせたいです。 5.最終行を求める処理は「GetLastRow」にて行います。 -------------------------------------------- Function GetLastRow() As Long ' 最終行を求める処理 Dim i As Long Dim MaxValue As Long For i = 5 To 500 If Cells(i, "A").Value <> "" Then ' A列からJ列に入力されている値の最大値を求める MaxValue = Application.WorksheetFunction.Max(Range("A" & i & ":J" & i)) If MaxValue > GetLastRow Then GetLastRow = i End If End If Next End Function -------------------------------------------- Private Sub CheckAcolumnBrank() ' A列がブランクの場合、1つ上の値をコピペする処理 Dim currentRow As Long Dim emptyColumns As Boolean Dim Lcont As Long Lcont = GetLastRow Dim ws As Worksheet Set ws = Sheets("シート1") emptyColumns = False ' A列を埋めるループ処理開始 currentRow = 6 Do While currentRow <= Lcont If IsEmpty(ws.Cells(currentRow, 1).Value) Then ws.Cells(currentRow, 1).Value = ws.Cells(currentRow - 1, 1).Value End If ' 終了条件のチェック(E列からJ列がすべて空白、かつA列の1つ上の値が異なる場合に終了) If ws.Cells(currentRow, 5).Value = "" _ And ws.Cells(currentRow, 6).Value = "" _ And ws.Cells(currentRow, 7).Value = "" _ And ws.Cells(currentRow, 8).Value = "" _ And ws.Cells(currentRow, 9).Value = "" _ And ws.Cells(currentRow, 10).Value = "" _ And (ws.Cells(currentRow, 1).Value <> ws.Cells(currentRow - 1, 1).Value) Then Exit Do End If currentRow = currentRow + 1 Loop End Sub -------------------------------------------- Private Sub CheckBcolumnBrank() ' B列がブランクの場合、1つ上の値をコピペする処理 Dim currentRow As Long Dim emptyColumns As Boolean Dim Lcont As Long Lcont = GetLastRow Dim ws As Worksheet Set ws = Sheets("シート1") emptyColumns = False ' ループ開始 currentRow = 6 Do While currentRow <= Lcont If ws.Cells(currentRow, 2).Value = "" Then ws.Cells(currentRow, 2).Value = ws.Cells(currentRow - 1, 2).Value End If ' 終了条件のチェック(E列からJ列がすべて空白、かつB列の1つ上の値が異なる場合に終了) If ws.Cells(currentRow, 5).Value = "" _ And ws.Cells(currentRow, 6).Value = "" _ And ws.Cells(currentRow, 7).Value = "" _ And ws.Cells(currentRow, 8).Value = "" _ And ws.Cells(currentRow, 9).Value = "" _ And ws.Cells(currentRow, 10).Value = "" _ And (ws.Cells(currentRow, 2).Value <> ws.Cells(currentRow - 1, 2).Value) Then Exit Do End If currentRow = currentRow + 1 Loop Set ws = Nothing End Sub --------------------------------------------

  • VBA最終行迄をコピーし別ファイルへ追加したいです

    大変お世話になっております。 1)Sheet1の2行目から最終行までを取得・コピーをし、同名のシート(Sheet1)の最終行へ追加したいです。 2)BOOK1のSheet1で作業をしており、BOOK2のSheet1へ貼り付けを行います。 3)BOOK1・BOOK2 共に、最終行の判定はC列に文字が入っているものとします。 以下ですと、列が限定されてしまうため、どのようなコードを作成すればよいのか教えていただけると有難い限りです…。 ※将来的には、BOOK1の名前が異なる13シート分をBOOK2(BOOK1と同じ名前のシートが13シートあります)へ同様の作業を行いたいです…。 Sub タイトル行を除き別ファイルに追加() ' Sheets("Sheet1").Activate Rows("2:7").Select Selection.Copy Windows("BOOK2.xlsm").Activate Rows("25:25").Select Selection.Insert Shift:=xlDown Windows("BOOK1.xlsm").Activate Sheets("Sheet1").Activate Application.CutCopyMode = False End Sub ご回答を心よりお待ちしております…。 お手数ですが、どうぞ宜しくお願い申し上げます。

  • 報酬付き

    エクセル セルの先頭の0 VBAで

    テキストファイル.txtにおける数値 たとえば01234567の8桁を エクセルファイルの(A,1)セルに移動すると 1234567と表示されてしまいます あるコードがあるとしまして 途中省略しますが ・・・・・ .Cells(A, 1).Value = Str(Mid(buf, Pos9 + Len9, Pos10 - (Pos9 + Len9))) これは あるプログラムの流れということですが これで 1234567 となってしまうので このコードのあとに Range (Cells(A, 1)) .NumberFormatLocal = "@" .Value = Format(.Value, "00000000") (この場合は 8桁とすでにわかっている場合ですが もし先頭に0がいくつ付くかわからない場合のケースも 教えていただけますか) とつけましたが エラーとなります 御教示くださいませ win10 office356

  • 全シート内の差分比較とそのセル色塗りつぶしマクロ

    Excelファイルデータの差分比較とそのセル塗りつぶしのマクロを作成したいのですが、今の自分には、下記のマクロでとどまっており、 マクロを実行するファイル内シートにデータをコピーしたり、 マクロ内でその都度、シート名の記載の変更、差分比較データ範囲の変更が必要になり、大変不便で困っております。 やりたい事は、マクロでユーザがExcelのファイルを選択出来て、 そのファイルの中の全シートのデータについて、差分比較とそのそのセルの塗りつぶしをして、塗りつぶしをファイルへ反映させて保存させることです。 どうか、お分かりの方がいらっしゃいましたら、ご教示をお願い出来ますと大変助かります。 各シート内のデータは、列、行共にほぼ同じフォーマットで値が入っています。 それらのシート内のデータで修正した箇所を見つける為、差分比較がしたいです。 例えば、シートが3つの場合は、 1つ目のシートは修正前のデータ、 2つ目のシート内は1つ目のシートの値を部分的に修正したものです。 3つ目のシート内のデータも、1つ目のデータの値を更に再修正したものです。 この3つのシート内のデータを差分比較したいです。 シートの数は、選択したファイルによって異なります。 Sub TEST1() Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用 Set s1 = Worksheets("修正前S装置検索システム") '比較元シート名 Set s2 = Worksheets("修正後装置検索システム") '比較先シート名 Dim arr1 As Variant, arr2 As Variant arr1 = s1.Range("$A$2:$W$548").Value arr2 = s2.Range("$A$2:$W$548").Value For i = 1 To UBound(arr1, 1) For j = 1 To UBound(arr1, 2) If arr1(i, j) <> arr2(i, j) Then '塗りつぶし処理 s1.Cells(i + 1, j).Interior.Color = RGB(255, 0, 0) s2.Cells(i + 1, j).Interior.Color = RGB(102, 255, 51) End If Next Next End Sub

  • 報酬付き

    Excel vbaでフォームの起動が失敗する

    Excelシート上に設置したユーザフォームを開くボタンを実行するとフォームが開かずに新規のExcelシートが開いてしまいます。 以前までは正常に作動していたんですが••• ちなみにボタンの実行前に vbaの編集画面を一度でも開いた後はボタンを押したら正常にフォームが開くんです。 フォームを開くコード sub 起動() UserForm1.Show End Sub フォームのInitializeはコンボボックスのみです。 原因がわかりましでしょうか?

  • 報酬付き

    テキストファイルとして開くVBA

    フォルダC:\Users\USER\Desktop\あいう において このダイアログを開いて そのなかのファイル(A.xml)を txtファイルとして開いて その名前を テキスト.txt として 同名で保存したいのですが Dim FileName As Variant Dim NewFile As TextFile FileName = Application.GetOpenFilename() Set NewFile = TextFile.Open(FileName) NewFile.SaveAs "テキスト.txt" Activetxtfile.SaveAs FileName:="C:\Users\PC\Desktop\あいう\テキスト.txt", FileFormat:=TextFile どうも違うようです 御教示ください

  • エクセルブックが開けなくなった。

    エクセルブックが開けなくなった。 添付のようなメッセージが出た後、立ち上がったと思ったら消えてしまいます。 シートは10枚位ありコマンドボタンでマクロを起動させています。 昨日まで何の異常もなく動いていましたが、今朝からおかしくなってしまいました。どうすれば回復するかのご教示を頂ければ有難いです。

  • VBA シートイベント

    シートイベントについて教えて下さい。 A3〜A100まで計算式が入っています。 そのため、A3〜A100のセルにカーソルが動いた時に注意メッセージを表示しています。シートイベントで設定しています。 ファイル保存時、入力漏れチェックのプログラムも入れています。 入力漏れチェック実行時、自動的にA列に設定したシートイベントも実行され、メッセージボックスが表示されてしまいます。 入力漏れチェック時は、A列のシートイベントを実行不可にしたいです。 良い方法はありませんでしょうか。

  • 4次方程式の解を求めるマクロ

    今学校で4次方程式の解を求めるマクロを作っています。 2次方程式までは作りました。なんかプログラムが書かれた紙をもらって打ち込んだらできました。そのあと4次方程式(ax^4+bx^2+c=0)を作る方法を考えてどんなふうに2次方程式のプログラムを変えたらいいか考えたんですけど、その考え方が合ってるかと、プログラムを変えたところがあってるかをみてほしいです。 まずx^2をmと置いて、am^2+bm+c=0にすると、m=-b±√b^2-4ac / 2a になってここからxを求めると、x=±√ -b±√b^2-4ac / √2a となると思います。そしたら解が4つ最大で出ると思うので、下の画像のようにプログラムを書き換えました。 家にはパソコンがなくて、学校でやろうと思うので、お返事は遅くなってしまうかもしれません。よろしくお願いします。

  • エクセルVBA ファイル名操作

    エクセルマクロのコードにおきまして 「フォルダの選択」ダイアログから エクセルファイル 123.xlsxを例えば 開くときに それをa.xlsxという名前に変えて 以下のそれに続くVBAコードにおいて a.xlsxを操作したいのですが、 a = Application.GetOpenFilename() Workbooks.Open a これを実行すると求めるダイアログが表示されて 使いたい123.xlsxを開くをクリックしますが これでは123.xlsxがa.xlsxにはなりません このa.xlsxのファイル名で別途ファイル作成する方法を 御教示いただけると助かります よろしくお願いします win10 office365 コードは以下 部分ですが こういう流れで作成したい所存です Sub あいう() a = Application.GetOpenFilename() Workbooks.Open a 'b.xlsxファイルを新規作成 Workbooks.Add ActiveWorkbook.SaveAs Filename:="C:\Users\USER\Desktop\あいう\b.xlsx", FileFormat:=xlXMLSpreadsheet 'a.xlsxファイルの1行目のA1~AG1のセルの値をコピー Workbooks("a.xlsx").Worksheets("Sheet1").Range("A1:AG1").Copy 'b.xlsxファイルのA3~AG3のセルに貼り付け Workbooks("b.xlsx").Worksheets("Sheet1").Range("A3:AG3").PasteSpecial xlPasteValues 以下省略 よろしくお願いします

  • Excelに対応してコンボボックスを選択するマクロ

    Excelのコンボボックスの表記と同じ表記のものをゆっくりムービーメーカーという別アプリの指定したコンボボックスから選ぶVBAマクロを開発したいです。カスタムと書かれたコンボボックスを動かしたいです。ですが、他にもclassnameやAoutmationIDが同じコンボボックスがあります。その中で自分の指定したコンボボックスを動かす方法も教えて頂きたいです。エクセルの「セリフ」sheetのE列にコンボボックスがあり、コンボボックスの中身は「表情」sheetのA列の表記(例魔理沙笑う) Excelのコンボボックスの表記と同じ表記のものをゆっくりムービーメーカーという別アプリの指定したコンボボックスから選択するVBAマクロを開発したいです。見づらいですが画像の右端の真ん中くらいにあるカスタムと書かれたコンボボックスを動かしたいです。ですが、他にもclassnameやAoutmationIDが同じコンボボックスがあります。その中で自分の指定したコンボボックスを動かす方法も教えて頂きたいです。エクセルの「セリフ」sheetのE列にコンボボックスがあり、コンボボックスの中身は「表情」sheetのA列の表記(例:魔理沙笑う)です。ゆっくりムービーメーカーのコンボボックスにも「表情」sheetのA列の表記(例:魔理沙笑う)と同じものが複数存在します。私はゆっくりムービーメーカーのコンボボックスの中からExcelのコンボボックスの表記と同じ表記のものを選択するVBAマクロを開発したいです。ご指導よろしくお願いします。下のマクロを改良したいですが、あくまで前のバージョンかつ私が作りたいマクロと似ていますが違うものなので参考程度にお願いします。 これと全く違うスクリプトでも構いません。よろしくお願いいたします。 Private Sub zputTachieParam(Param() As Variant) Dim i, j, k, row_blank, f_hetitem As Integer Dim x_char As String Dim tmp, x_last_item As Variant Dim elmYukkuri_tachie As IUIAutomationElement 'RegExpオブジェクトの作成 Dim reg As Object Set reg = CreateObject("VBScript.RegExp") '正規表現の指定 With reg .Pattern = "[^0-9]" 'パターンを指定 .IgnoreCase = False '大文字と小文字を区別するか(False)、しないか(True) .Global = True '文字列全体を検索するか(True)、しないか(False) End With hWnd = FindWindowA(vbNullString, C_アプリ名) Set uiAuto = New CUIAutomation Set elmYukkuri = uiAuto.ElementFromHandle(ByVal hWnd) Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "ItemEditorView") Set elmYukkuri = elmYukkuri.FindFirst(TreeScope_Subtree, iCnd) Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "ScrollViewer") Set elmYukkuri = elmYukkuri.FindFirst(TreeScope_Subtree, iCnd) Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "Editor") Set elmYukkuri = elmYukkuri.FindFirst(TreeScope_Subtree, iCnd) Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "立ち絵") Set elmYukkuri = elmYukkuri.FindFirst(TreeScope_Subtree, iCnd) Dim elms_ComboBox As IUIAutomationElementArray Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "ComboBox") Set elms_ComboBox = elmYukkuri.FindAll(TreeScope_Children, iCnd) Dim ptnVal As IUIAutomationSelectionItemPattern f_hetitem = 0 x_last_item = "" For j = 0 To elms_ComboBox.Length - 1 tmp = Split(elms_ComboBox.GetElement(j).CurrentHelpText, "\") If UBound(tmp) > 0 Then '選択されてるコンボボックス '現状の設定とパラメータ値を比較 If Param(j) <> Int(Replace(tmp(UBound(tmp)), ".png", "")) Then elms_ComboBox.GetElement(j).SetFocus 'ENDキーで最後の選択肢に持っていく wshSendKeys "{END}", True f_hetitem = 0 For k = 0 To 200 elms_ComboBox.GetElement(j).SetFocus 'Debug.Print "1> " & elms_ComboBox.GetElement(j).CurrentHelpText tmp = Split(elms_ComboBox.GetElement(j).CurrentHelpText, "\") If UBound(tmp) > 0 Then 'Debug.Print "2> " & reg.Replace(tmp(UBound(tmp)), "") If Param(j) = Int("0" & reg.Replace(tmp(UBound(tmp)), "")) Then f_hetitem = 1 Exit For End If wshSendKeys "{UP}", True Else 'Debug.Print "nohit!" wshSendKeys "{DOWN}", True Exit For End If Next End If End If Next Sleep 100 End Sub

    • ベストアンサー
    • noname#259561
    • Visual Basic
    • 回答数1
  • VB.NET DataTableについて

    質問失礼します。 VB.Netで、テーブルに格納されたデータをDataTableを利用し、SQLを実行、抽出してきました。 その結果から、さらに抽出したいのですが、方法がわかりません。 dataに格納したものは、問題なく抽出できています。(データセットビジュアライザーで確認済み) 以下、 番号 名前 合計 1 りんご 10 2 ぶどう 20 3 りんご 30 の、ように3行結果が取れました。 そこから、名前が重複していル値があるかどうか、またその数を確認したいです。 (りんごが、2行ある) この方法がどうしてもわからず、 Dim rows As DataRow() から rows = data.Select("名前 = りんご") とすれば、りんごが2行あると数がわかりますが、 これが、りんごとは、限らないため、 重複している名前があるか、どうかを調べたいところです。 勉強して、まだ浅く、わかりづらい説明で申し訳ありませんが、ご回答のよろしくお願いします。

  • ゆっくりムービーメーカーを動かすExcelVBAの

    https://www.youtube.com/watch?v=r_9JLzXMsk4&t=16s この動画のマクロをゆっくりムービーメーカーの最新のバージョンでも使えるようにしてほしいです。或いは立ち絵変更の時にカスタムをいじってスムーズに立ち絵変更が出来るようにしてほしいです。v14.01ではバージョン名の変更を除いてそのまま利用できました。よろしくお願いします。

  • VBAセル番地が移動したとき更新するには

    前回の質問の延長になります。 https://okwave.jp/qa/q10219443.html#answers Sub Step1_copy() Worksheets("RAsheet").Range("D8").Value = Worksheets("RAsheet").Range("X9").Value End Sub 入力フォームの入力欄にINDEX関数で抽出した値を代入して入力作業を簡略しようとしています。 抽出セルX9を番地ではなく名前で宣言して格納し、代入などでセル番地を指定していた箇所に名前を入れてセル番地が移動したときに一括で反映させるようにする方法はありますでしょうか。 詳しい方いましたらご教授ください。

  • VBAの作成方法について

    マクロ初心者です。 エクセルの値のコピペに時間がかかっているため、マクロを使って自動化させたいと思っています。 どなたかソースを教えていただけますでしょうか? <内容>  ・「実績データ」という名前のエクセルデータに値を貼付けさせたい。   シート構成は「140」「540」といった部門コード名のシートが複数あります。  ・値を持っている別エクセルデータは「実績データ140」と最後に部門コード3桁をつけた名前になります。  ・「実績データ140」のデータを「実績データ」のシート140にそのデータを貼付けしたい。  ・なお、「実績データ140」ファイルのシート名は140です。

  • 既定のプリンターに設定するマクロ

    マクロを設定したのですがうまくいきません。なぜでしょうか。プリンターの名前はプロパティからそのままコピーしたので名前は大丈夫だと思います。 実行時エラー 1004 コントロールが表示されていない、利用できない、またはフォーカスを持てないため、そのコントロールにフォーカスを移すことはできません。 少し時間をおいて開いた時 実行時エラー 1004 ActivePrinterメソッドは失敗しました。 Option Explicit Private Sub Workbook_Open() Application.ActivePrinter = "iR-ADV C3530 III" End Sub

  • vbaで外部アプリの起動

    ユーザーフォーム内に作成したボタンをクリックすると、バーコードマネージャforWindowsが起動して読みこんだQRコードをテキストboxに転記するような事は出来るでしょうか? まずはバーコードマネージャを起動してみようと実行ファイルの場所を探したんですが見つかりません。 可能であればコード例を教えてください。

  • マクロでテーブルの日時のオートフィルターの制御

    テーブルには「1~6時」、「1日中」、「6~8時,21~22時」などいろいろな時間が書いてあるセルがあります。このテーブルにマクロを使って「1時」「2時」...「24時」などのボタンを24個作りオートフィルターの絞り込みをしようとしています。 このままでは使いづらいので検索列というものを作り、「1時,2時,3時,4時,5時,6時」、「1日中」、「6時,7時,8時,21時,22時」と入力しました。 とりあえず「1時」の絞り込みのマクロを作りました。 Option Explicit Sub One_Oclock() With ActiveSheet.ListObjects(1) .Range.AutoFilter .ListColumns("検索列").Index, _ "1時*", xlOr, "1日中" End With End Sub 1時はセルの頭にくるのでこれで11時や21時を除外することはできましたが逆に「1時」のみのセルは除外されてしまいました。 また2時の場合は「"*2時*"」、「"*2時"」「"2時*"」「"1日中"」となりやはりうまくいきません。どうすればいいですか。

  • VBA セルの値を別セルにコピーするには

    VBAでPastespecialでセルの値を別セルにコピーするマクロを組みたいです。 以下は参考にしたソースコードです。 Worksheets("Sheet1").Range("A1:B10").Copy Worksheets("Sheet2").Range("A1").PasteSpecial _                  Paste:=xlPasteValues, _                  Operation:=xlNone, _                  SkipBlanks:=False, _                  Transpose:=False あるExcelマクロの入力フォームSheetに、製品リストと使用している場所のマスタデータをクエリで読み込んで、製品IDと場所のコードを入力したらINDEX関数で抽出し、マクロ実行ボタンを押すと抽出結果を入力フォームの入力欄に貼り付けします。 上記のマクロだと貼り付けする元セルを移動させたら内容がずれた値がそのまま貼り付けされてしまうと思われますが、地道にコードのコピー元のセルを書き直さないといけないのでしょうか。 Excelの関数だと参照範囲を固定したら掴んで移動させてもセル番地が連動して移動してくれますが、マクロの場合どのようにすれば良いでしょうか。 また、複数個所のセルをコピーするので Paste:=xlPasteValues, _ Operation:=xlNone, _ SkipBlanks:=False, _ Transpose:=False をコピーするセルの箇所に毎回入れていますが、コピー元のセル・コピー先のセル番地を一括して実行する方法はありますでしょうか。 VBAはソースコードを参考に当てはめているだけで、自力でコードを書くスキルは皆無です。 Excelは2016です。 詳しい方いましたらご教授ください。よろしくお願い致します。

  • Excelマクロ 複数の条件と範囲条件

    色々と自分でもやってみたのですがうまくいかないので教えて頂けたら嬉しいです。 添付画像の左側の様な伝票番号と通し番号と商品名がふってあるシートが存在します。 同じ伝票番号内で商品に「松」もしくは「梅」が含まれているときのみ、その伝票番号の最終行に「送料」の行を追加したいです。その際に通し番号も加算したものを追加します。 これが上手く作れません。 ↓とりあえず作りかけたものの変に行が挿入されるマクロを記載します。ここからの修正でうまくいくなら修正点を教えて頂けると幸いです。 Sub 更新伝票情報() Dim lastRow As Long Dim currentRow As Long Dim currentInvoice As String Dim currentNumber As Integer ' シートの最終行を取得 lastRow = Cells(Rows.Count, 1).End(xlUp).Row ' 初期値の設定 currentInvoice = Cells(2, 1).Value currentNumber = 1 ' 行ごとに処理 For currentRow = 2 To lastRow ' 伝票番号が変わった場合 If Cells(currentRow, 1).Value <> currentInvoice Then ' 新しい伝票番号の設定 currentInvoice = Cells(currentRow, 1).Value ' 通し番号をリセット currentNumber = 1 End If ' 商品名に「松」または「梅」が含まれる場合 If InStr(1, UCase(Cells(currentRow, 3).Value), UCase("松")) > 0 Or InStr(1, UCase(Cells(currentRow, 3).Value), UCase("梅")) > 0 Then ' 最終行の下に新しい行を挿入 Rows(currentRow + 1 & ":" & currentRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ' 通し番号を加算し、B列を更新 Cells(currentRow + 1, 2).Value = currentNumber ' C列を「送料」に更新 Cells(currentRow + 1, 3).Value = "送料" ' 通し番号を1つ加算 currentNumber = currentNumber + 1 End If Next currentRow End Sub