質問番号:1471574675
http://q.hatena.ne.jp/1471574675
Excelの特定のセルで計算を行いたいが同時に日本語も入れたい
今、C20セル〜から数行に渡り、営業費8,000円×30=
管理費5,000円×20=
撮影費1,000円×15=
・
・
・
と、計算を含む文字列が入っております。
上記の費用の計算結果を、D20セル以下に表記したいのですが。余計な日本語や全角の記号(×や=)が混じっているので、単純にセルに“=”を入れて掛算式を入れても、うまく計算ができないです。
しかし書類の仕様上、それらの日本語を消すことも出来ない状況です。
日本語の●●費等を残しつつも、C列に計算式を入れて、同時に計算結果をD列に反映するような妙案はないでしょうか。
よろしくお願い致します。
汎用性を持たせる為に、数字、小数点、演算子に全角・半角が混在していても計算する様にしました。
プログラム
Option Explicit Function StrToFormula(ByVal Str As String) As Variant Dim FirstNo As Variant ' 第一引数 Dim SecondNo As Variant ' 第二引数 Dim Operator As String ' 演算子 Dim Flag As Boolean Dim lp As Integer ' コンマを削除 Str = Replace(Str, ",", "") ' 演算子抽出 Flag = True If InStr(Str, "+") > 0 Or InStr(Str, "+") > 0 Then Operator = "+" Str = Replace(Str, "+", ",") Str = Replace(Str, "+", ",") ElseIf InStr(Str, "−") > 0 Or InStr(Str, "-") > 0 Then Operator = "-" Str = Replace(Str, "−", ",") Str = Replace(Str, "-", ",") ElseIf InStr(Str, "×") > 0 Or InStr(Str, "*") > 0 Then Operator = "*" Str = Replace(Str, "×", ",") Str = Replace(Str, "*", ",") ElseIf InStr(Str, "÷") > 0 Or InStr(Str, "/") > 0 Then Operator = "/" Str = Replace(Str, "÷", ",") Str = Replace(Str, "/", ",") Else Flag = False End If ' 演算子が無い If Flag = False Then StrToFormula = "" Exit Function End If '演算子で分割 FirstNo = Split(Str, ",")(0) SecondNo = Split(Str, ",")(1) ' 数字と小数点以外の文字を空白に変換した後、削除 For lp = 1 To Len(FirstNo) If (Mid(FirstNo, lp, 1) >= "0" And Mid(FirstNo, lp, 1) <= "9") = False And _ (Mid(FirstNo, lp, 1) >= "0" And Mid(FirstNo, lp, 1) <= "9") = False And _ (Mid(FirstNo, lp, 1) = "." And Mid(FirstNo, lp, 1) = ".") = False Then Mid(FirstNo, lp, 1) = " " End If Next lp FirstNo = StrConv(Replace(FirstNo, " ", ""), vbNarrow) For lp = 1 To Len(SecondNo) If (Mid(SecondNo, lp, 1) >= "0" And Mid(SecondNo, lp, 1) <= "9") = False And _ (Mid(SecondNo, lp, 1) >= "0" And Mid(SecondNo, lp, 1) <= "9") = False And _ (Mid(SecondNo, lp, 1) = "." And Mid(SecondNo, lp, 1) = ".") = False Then Mid(SecondNo, lp, 1) = " " End If Next lp SecondNo = StrConv(Replace(SecondNo, " ", ""), vbNarrow) ' 抽出した数字と演算子で計算 Select Case Operator Case "+" StrToFormula = Val(FirstNo) + Val(SecondNo) Case "-" StrToFormula = Val(FirstNo) - Val(SecondNo) Case "*" StrToFormula = Val(FirstNo) * Val(SecondNo) Case "/" StrToFormula = Val(FirstNo) / Val(SecondNo) End Select End Function
標準モジュールに記述
質問番号:11162376606
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11162376606
下記のフォルダーにPDF形式の図面ファイルを入れてあります。
C:\Users\kojin\Desktop\製造工程\図面\123.pdf 等これら図面をExcelVba にて印刷したいのですが
但しPDFファイルを開かず実行できるのがBestですが
印刷終了後はpdfを閉じるようにしたいと思っております。どなたかご教授頂ければ助かります。
プログラム
Option Explicit ' レジストリ値取得用API Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _ (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _ ByVal samDesired As Long, phkResult As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _ lpType As Long, lpData As Any, lpcbData As Long) As Long ' レジストリ値取得用定数 Const KEY_QUERY_VALUE = &H1 Const HKEY_LOCAL_MACHINE = &H80000002 ' PDF印刷用定数 Const PrintOK As Integer = 0 Const NoFile As Integer = -1 Const StatusNG As Integer = -2 Const AdobeReaderNG As Integer = -3 '概要 Yahoo知恵袋 質問番号:Q11162376606 2016.08.02 Sub Main() Dim DirName As String Dim FileName As String Dim Res As Integer ' DirName = "C:\Users\kojin\Desktop\製造工程\図面\" ' FileName = "123.pdf" DirName = "Z:\" FileName = "sample.pdf" Res = PDFPrint(DirName, FileName) If Res = NoFile Then MsgBox "指定されたファイルは存在しません!", vbExclamation + vbOKOnly ElseIf Res = StatusNG Then MsgBox "通常使うプリンタのステータスが取得できません!", vbExclamation + vbOKOnly ElseIf Res = AdobeReaderNG Then MsgBox "Acrobat Readerがインストールされていません!", vbExclamation + vbOKOnly End If End Sub '概要 コマンドラインから指定されたPDFファイルを印刷する ' '引数 DirName : 印刷するPDFファイルのフォルダ名 ' FileName : 印刷するPDFファイル名 ' '返値 PrintOK (0) : 正常終了 ' NoFile(-1) : 指定されたPDFファイルが存在しない ' StatusNG(-2) : プリンタ名、ドライバ名、ポート名のいずれかの情報が取得できない ' AdobeReaderNG(-3) : Adobe Readerがインストールされていない Private Function PDFPrint(DirName As String, FileName As String) As Integer Dim WSH As Object Dim WExec As Object Dim Path As String Dim Result As String Dim PrinterName As String Dim DriverName As String Dim PortName As String Dim AdobeReaderInstallFolder As String Dim CommandCode As String Dim Tmp As Variant Dim lp As Integer ' 指定されたPDFファイルが存在するか? If Right(DirName, 1) <> "\" Then DirName = DirName & "\" End If If Dir(DirName & FileName) = "" Then PDFPrint = NoFile Exit Function End If ' OSのバージョンチェック If InStr(Application.OperatingSystem, "5.01") > 0 Then Path = "C:\Windows\System32\" ' WindowsXP Else Path = "C:\Windows\System32\Printing_Admin_Scripts\ja-JP\" ' Windows Vista以上 End If Set WSH = CreateObject("WScript.Shell") ' 通常使うプリンタ名取得 Set WExec = WSH.exec("cscript " & Path & "prnmngr.vbs -g") Result = WExec.StdOut.ReadAll Tmp = Split(Result, vbCrLf) PrinterName = Split(Tmp(3), ": ")(1) ' ドライバ名・ポート名取得 Set WExec = WSH.exec("cscript " & Path & "prnmngr.vbs -l") Result = WExec.StdOut.ReadAll Tmp = Split(Result, vbCrLf) lp = 0 Do While UBound(Tmp) >= lp If InStr(Tmp(lp), "プリンター名 ") > 0 Then If InStr(Tmp(lp), PrinterName) > 0 Then DriverName = Replace(Tmp(lp + 2), "ドライバー名 ", "") PortName = Replace(Tmp(lp + 3), "ポート名 ", "") Exit Do End If End If lp = lp + 1 Loop ' プリンタのステータスが取得できない If PrinterName = "" Or DriverName = "" Or PortName = "" Then Set WSH = Nothing Set WExec = Nothing PDFPrint = StatusNG Exit Function End If ' Acrobat Reader(Adobe Reader)のインストールパスをレジストリから取得 AdobeReaderInstallFolder = GetRegValue(HKEY_LOCAL_MACHINE, _ "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe", "Path") If AdobeReaderInstallFolder = "" Then Set WSH = Nothing Set WExec = Nothing PDFPrint = AdobeReaderNG Exit Function End If ' PDFファイルを印刷 CommandCode = AdobeReaderInstallFolder & "AcroRd32.exe /t " & DirName & FileName & " " & _ Chr(34) & PrinterName & Chr(34) & " " & Chr(34) & DriverName & Chr(34) & " " & PortName Set WExec = WSH.exec(CommandCode) ' AdobeReaderを閉じる CommandCode = "taskkill /IM AcroRd32.exe" Set WExec = WSH.exec(CommandCode) Set WSH = Nothing Set WExec = Nothing PDFPrint = PrintOK End Function '概要 レジストリの値を取得する ' '引数 lngRootKey : レジストリルートキー ' strSubKey : レジストリサブキー ' strName : 名前 ' '返値 取得したレジストリの値 ' '注釈 「EXCEL VBA:レジストリ情報取得・yuriのIT手帳」(http://blog.livedoor.jp/yorinaga/archives/52016032.html)参照 Function GetRegValue(lngRootKey As Long, strSubKey As String, strName As String) As String Dim lngRet As Long Dim hWnd As Long Dim strValue As String 'ハンドルを開く hWnd = Application.hWnd lngRet = RegOpenKeyEx(lngRootKey, strSubKey, 0, KEY_QUERY_VALUE, hWnd) '受け取り値用のバッファを確保 strValue = String(255, " ") '値を取得 lngRet = RegQueryValueEx(hWnd, strName, 0, 0, ByVal strValue, LenB(strValue)) 'ハンドルを閉じる RegCloseKey hWnd '取得した値から後続のNullを取り除く strValue = Left(strValue, InStr(strValue, vbNullChar) - 1) '取得した値を返り値に設定 GetRegValue = strValue End Function
参考サイト
Windowsのバージョン情報取得
https://www.moug.net/tech/exvba/0150124.html
Windowsの種類を取得する・morg(モーグ)
プリンタの情報(既定のプリンタ名、ドライバ名、ポート名)
http://www.town.yakumo.lg.jp/modules/information_blog/details.php?bid=871
プリンタの情報取得・北海道八雲町情報政策課ブログ
https://msdn.microsoft.com/ja-jp/library/cc772768(v=ws.10).aspx
Prnmngr.vbs・マイクロソフト
Prnmngr.vbs
プリンタまたはプリンタ接続を追加、削除、および一覧表示します。また、既定のプリンタを設定および表示します。パラメータを付けずに prnmngr.vbs を実行すると、prnmngr.vbs コマンドのコマンド ライン ヘルプが表示されます。
Adobe Readerのプロパティ取得及び印刷(Adobe Readerのインストールフォルダ)
https://helpx.adobe.com/jp/acrobat/kb/511265.html
レジストリから Acrobat・Adobe Reader のバージョン情報を得る方法について(別解)・Adobe
http://pdf-file.nnn2.com/?p=222
WINDOWS のコマンドラインから ACROBAT や ADOBE READER を使用して印刷する方法・VBA(Excel)からAcrobat経由でPDFをプログラミング操作(OLE:IAC)する
http://blog.livedoor.jp/yorinaga/archives/52016032.html
EXCEL VBA:レジストリ情報取得・yuriのIT手帳
質問番号:1467245868
指定した約1000のキーワードを含む行を削除したいです
今、Sheet1のA列にずらりとデータが2万行ほど並んでいます。
そしてSheet2のC列に、1000行ほどデータが並んでおります。この状況におきまして、Sheet2のC列の1000行(1000セル)のデータの各文字列が、もしSheet1のA列の各セル(20000セル)に含まれていた場合。
該当するA列のデータを、行ごと削除していきたいのです。そのような処理がマクロ等で可能でしたらお教えいただけないでしょうか。
よろしくお願い致します。
質問文の内容とは少し違いますが、セルの値を検索する方法を4つのアルゴリズムで比較してみました。
比較アルゴリズム
・検査値のセルと検索値のセルを単純に2重ループで比較(Test1)
・Match関数(ワークシート関数)を利用して検索(Test2)
・検査値と検索値をバリアント配列にコピーした後、2重ループで比較(Test3)
・Findメゾットを利用して検索(Test4)
条件
・全部の方法で同一のデータを利用する。(検査値、検索値共に数字・アルファベット大文字小文字をランダムに10文字抽出)
(テストデータは「ランダム文字列ジェネレータ」http://app.nanoway.net/random/ を利用しました。)・検索値は必ず見つかるものとする。(見つからない場合の処理は今回省略)
・検査値が見つかったら、対応する配列にTrue(論理値)をセットする。
プログラム
Option Explicit Const Quantity As Integer = 100 ' 検索件数 Sub main() Dim StartTime As Date Dim EndTime As Date Dim DustTime1 As Date Dim DustTime2 As Date Dim DustTime3 As Date Dim DustTime4 As Date StartTime = Time Call Test1 EndTime = Time DustTime1 = EndTime - StartTime StartTime = Time Call Test2 EndTime = Time DustTime2 = EndTime - StartTime StartTime = Time Call Test3 EndTime = Time DustTime3 = EndTime - StartTime StartTime = Time Call Test4 EndTime = Time DustTime4 = EndTime - StartTime MsgBox "検索件数:" & Quantity & vbCrLf & "TEST1:" & Format(DustTime1, "hh:mm:ss") & vbCrLf & "TEST2:" & Format(DustTime2, "hh:mm:ss") & vbCrLf & "TEST3:" & _ Format(DustTime3, "hh:mm:ss") & vbCrLf & "TEST4:" & Format(DustTime4, "hh:mm:ss") End Sub Function Test1() Dim WS1 As Worksheet Dim WS2 As Worksheet Dim MaxRow As Integer Dim MatchFlag(20000) As Boolean Dim lp1 As Integer Dim lp2 As Integer Set WS1 = Worksheets(1) Set WS2 = Worksheets(2) MaxRow = WS1.Range("A" & Rows.Count).End(xlUp).Row For lp1 = 1 To Quantity For lp2 = 1 To MaxRow If WS2.Cells(lp1, 1) = WS1.Cells(lp2, 1) Then MatchFlag(lp2) = True Exit For End If Next lp2 Next lp1 End Function Function Test2() Dim WS1 As Worksheet Dim WS2 As Worksheet Dim RowNo As Integer Dim MatchFlag(20000) As Boolean Dim lp1 As Integer Set WS1 = Worksheets(1) Set WS2 = Worksheets(2) For lp1 = 1 To Quantity RowNo = Application.WorksheetFunction.Match(WS2.Cells(lp1, 1).Value, WS1.Range("A:A"), 0) MatchFlag(RowNo) = True Next lp1 End Function Function Test3() Dim WS1 As Worksheet Dim WS2 As Worksheet Dim MaxRow As Integer Dim Comp1 As Variant Dim Comp2 As Variant Dim MatchFlag(20000) As Boolean Dim lp1 As Integer Dim lp2 As Integer Set WS1 = Worksheets(1) Set WS2 = Worksheets(2) Comp1 = WS1.Range("A1:A20000") Comp2 = WS2.Range("A1:A" & Quantity) MaxRow = WS1.Range("A" & Rows.Count).End(xlUp).Row For lp1 = 1 To Quantity For lp2 = 1 To MaxRow If Comp2(lp1, 1) = Comp1(lp2, 1) Then MatchFlag(lp1) = True Exit For End If Next lp2 Next lp1 End Function Function Test4() Dim WS1 As Worksheet Dim WS2 As Worksheet Dim RowNo As Integer Dim MatchFlag(20000) As Boolean Dim lp1 As Integer Set WS1 = Worksheets(1) Set WS2 = Worksheets(2) For lp1 = 1 To Quantity RowNo = WS1.Cells.Find(WS2.Cells(lp1, 1)).Row MatchFlag(RowNo) = True Next lp1 End Function
結果
4種類のアルゴリズムで一番早かったのはMatch関数(Test2)を用いた方法でした。 ただ、バリアント配列(Test3)やFindメゾット(Test4)を用いた方法も実用に耐えうる速度が出ていると思います。
質問番号:11157355186
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11157355186
エクセルVBAについての質問です。キーボードの矢印によってセルの値を変える方法を教えてください。
例として、矢印↑を押すとセルA11の値に+1されて、矢印↓を押すとセルA11−1される。
また、矢印→を押すとセルK1の値に+1され、矢印←を押すとセルK1の値にー1される方法を教えてください。
回答
標準モジュール
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
シート1
Option Explicit Sub main() Do While (1) DoEvents ' ↑キーが押されたらA11セルの値をカウントアップ If GetAsyncKeyState(vbKeyUp) <> 0 Then Range("A11").Value = Range("A11").Value + 1 Range("A11").Select Sleep (100) End If ' ↓キーが押されたらA11セルの値をカウントダウン If GetAsyncKeyState(vbKeyDown) <> 0 Then Range("A11").Value = Range("A11").Value - 1 Range("A11").Select Sleep (100) End If ' →キーが押されたらK1セルの値をカウントアップ If GetAsyncKeyState(vbKeyRight) <> 0 Then Range("K1").Value = Range("K1").Value + 1 Range("K1").Select Sleep (100) End If ' ←キーが押されたらK1セルの値をカウントダウン If GetAsyncKeyState(vbKeyLeft) <> 0 Then Range("K1").Value = Range("K1").Value - 1 Range("K1").Select Sleep (100) End If ' エスケープキーが押されたら処理終了 If GetAsyncKeyState(vbKeyEscape) <> 0 Then Exit Do End If Loop End Sub
質問番号:1446515298
2〜4つの文字数バラバラの単語で構成される文字列を並べ替える方法につきまして
今、A列に次のような文字列が10000行近く、ずらりと並んでおります。
単語A★単語B★単語C■
単語D★単語E★単語F★単語G■
単語H★単語I■
単語J★単語K★単語L■
単語M★単語N■
単語O★単語P★単語Q★単語R■
・
・
・1つのセルは2〜4つの単語の文字列が入っております。
それぞれの単語自体はバラバラで特に規則性はないです。
単語と単語の間に★印があり、最後の単語の後ろには■がくっ付いております。
上記の状態から、単語C■単語A★単語B★
単語G■単語D★単語E★単語F★
単語I■単語H★
単語L■単語J★単語K★
単語N■単語M★
単語R■単語O★単語P★単語Q★
・
・
・と、並べ替えを行いたいのです。
量が多くて困っているのですが・・・何かよい並べ替えのマクロや関数等ありましたら、
お教えいただけないでしょうか。よろしくお願い致します。
2015.11.05追記 回答プログラムは実行したいシートに貼り付けてください。
回答
Option Explicit Sub StringExchange() Dim MAXROW As Long Dim SPCount As Integer Dim lp As Long Const SPChar As String = "★" MAXROW = Me.Range("A" & Rows.Count).End(xlUp).Row ' 0行の場合は即終了 If MAXROW < 1 Then Exit Sub End If For lp = 1 To MAXROW If Len(Cells(lp, 1)) > 0 Then ' 文字列後ろから★を探す SPCount = InStrRev(Cells(lp, 1), SPChar) If SPCount > 0 Then Cells(lp, 2) = Mid(Cells(lp, 1), SPCount + 1, Len(Cells(lp, 1))) & Left(Cells(lp, 1), SPCount) Else Cells(lp, 2) = Cells(lp, 1) End If End If Next lp End Sub
質問番号:1440684528
Excelの質問です。一番右端の半角スペース以降の文字列をすべて削除するような関数やマクロはないでしょうか。
今、B列に次のようなデータが、4万行近く並んでおります。
- -
らくだ 動物 アフリカ
らくだ 動物 特徴
らくだ 生息地 アジア
らくだ 生態 進化の過程
・・・
- -
といった感じです。
この状態から、一番右端の半角スペース以降の文字列全てを削除したいので、
- -
らくだ 動物
らくだ 動物
らくだ 生息地
らくだ 生態
・・・
- -
のようにしたいのですが・・・データが膨大で、手作業で行うのは途方もない作業です。
関数やマクロを用いて、何とか効率的に文字列を削除する方法はないでしょうか。よろしくお願い致します。
回答
Option Explicit Sub main() Dim MAXROW As Long Dim SPCount As Integer Dim lp As Long Const SPChar As String = " " MAXROW = Me.Range("A" & Rows.Count).End(xlUp).Row If MAXROW < 1 Then Exit Sub End If For lp = 1 To MAXROW ' 文字列後ろからスペースを探す SPCount = InStrRev(Cells(lp, 1), SPChar) If SPCount > 0 Then Cells(lp, 2) = Left(Cells(lp, 1), SPCount - 1) Else Cells(lp, 2) = Cells(lp, 1) End If Next lp End Sub
質問番号:14148951214
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14148951214
セル内の文字列の改行をVBAでプログラミングしたいと思っています。
エクセルVBAの初心者です。よろしくお願いします。特定のセル内に以下の文字列が入っていたとします。
- aaaaaaaaa+bbbbb+cccccccc+ddddddd+eeeeeee
この文字列を、
- aaaaaaaaa
- bbbbb
- cccccccc
- ddddddd
- eeeeeee
といった感じで、「+」の前で改行するには、どのようにVBAでプログラミングすればいいか、ご教授お願いします。
なお、「+」の数や、「+」と次の「+」間の文字数(上記の例だと、「a」「b」「c」とかの文字数)は全く決まっていません。初心者でうまく質問できているか不安ですが、どうかよろしくお願いします。
回答
Option Explicit Option Base 1 Sub main() Dim BeforeString As String ' 分割前文字列 Dim AfterString As Variant ' 分割後文字列配列 Dim Delimiter As String ' 区切り文字 Dim lp As Integer ' ループカウンタ ' 区切り文字設定 Delimiter = "+" ' A1セルの内容を分割前文字列にコピー BeforeString = Range("A1").Value ' 分割前文字列を区切り文字で分割 AfterString = Split(BeforeString, Delimiter) ' 文字分割ができない場合は処理終了 If UBound(AfterString) = 0 Then Exit Sub End If ' 分割後文字列配列の内容をB1セルから下にコピー For lp = 1 To UBound(AfterString) Range("B1").Offset(lp - 1).Value = AfterString(lp) Next lp End Sub
参考サイト
http://officetanaka.net/excel/vba/tips/tips62.htm
Split関数で文字列を区切る・OFFICE TANAKA
http://www.moug.net/tech/exvba/0100023.html
文字列を分割し1次元配列として返す(Split関数)・moug