以前にマクロの記述について教えて頂いた件の再度の質問になります．
Excelマクロで複素数を扱う関数を下記HPから標準モジュールに
コピペしました．今度は正しくコピーできていると思います．
しかし，計算結果がどうしても「#VALUE!」となってしまいます．何故でしょうか？
どなたか助けて頂けませんか！
http://www.geocities.jp/tomtomf/denki/AC2/ac2.htm
http://www.geocities.jp/tomtomf/denki/AC1/ac1.htm
今回は関数定義の「 IMMULT」関数に関する部分に絞っています．
ここまで絞ってもエラーになるのは，単純な問題なのでしょうか？
行列の積を求めるマクロの手順にも問題はなさそうです．
Public Function IMPRODUCTa(ParamArray a()) As Variant
IMPRODUCTa = Application.Run("atpvbaen.xlam!IMPRODUCT", a)
End Function
Public Function IMSUMa(ParamArray a()) As Variant
IMSUMa = Application.Run("atpvbaen.xlam!IMSUM", a)
End Function
Public Function IMMULT(a As Range, b As Range) As Variant
Dim r1 As Integer, r2 As Integer, c1 As Integer, c2 As Integer, nn As Integer
Dim r As Integer, c As Integer
Dim cr As Integer, cc As Integer
Dim n As Integer
Dim mm() As Variant
r1 = a.Rows.Count
r2 = b.Rows.Count
c1 = a.Columns.Count
c2 = b.Columns.Count
If c1 = r2 Then
nn = c1
Else
Exit Function
End If
cr = r1
cc = c2
ReDim mm(1 To cr, 1 To cc)
For r = 1 To cr
For c = 1 To cc
mm(r, c) = 0
For n = 1 To nn
mm(r, c) = IMSUMa(mm(r, c), IMPRODUCTa(a.Cells(r, n), b.Cells(n, c)))
Next
Next
Next
IMMULT = mm
End Function
長くなってしまって済みません。
先日（2018/12/28）ここで上記のマクロのコードを教えてもらって問題なく使い始めたのですが、別のBookにコピーして、ファイル名のセルを（10,4）と(1,1)から（15,4)と（1,1)）に変更すると「実行時エラー 13、型が一致しません」と出ます。
うまくいっているシートのファイル名はD10＋A1のセルで、今度はD15＋A1をファイル名にしただけなのですが。。。。
(10,4)と(1,1)のままだと普通にメールが起動してくるのですがD10が空白セルの為A1の内容だけでファイル名になってしまいます。
ちなみにそのシートのD10に数値＋アルファベットを入れると「型が一致しません」と上記と同じエラーが出ます。
教えてもらったコードのファイル名の（下の）セルの数値だけ変えたらうまくいったと思うのですが、今回はなぜかエラーになってしまいます。
質問ではA1＋B1で質問しましたので(1,1)と(1,2)になっています。
xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf"
全部のコードは下記の通りです。
Option Explicit
Sub Saveaspdfandsend()
Dim xSht As Worksheet
'Dim xFileDlg As FileDialog
Dim xFolder As String
'Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Const PdfDir = "C:\OKWave" 'PDFを保存するフォルダー
Set xSht = ActiveSheet
'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
'
'If xFileDlg.Show = True Then
' xFolder = xFileDlg.SelectedItems(1)
'Else
' MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
' Exit Sub
'End If
xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf"
'Check if file already exist
'If Len(Dir(xFolder)) > 0 Then
' xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
' vbYesNo + vbQuestion, "File Exists")
' On Error Resume Next
' If xYesorNo = vbYes Then
' Kill xFolder
' Else
' MsgBox "if you don't overwrite the existing PDF, I can't continue." _
' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
' Exit Sub
' End If
' If Err.Number <> 0 Then
' MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
' Exit Sub
' End If
'End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = ""
.Attachments.Add xFolder
'If DisplayEmail = False Then
'.Send
'End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
下記のようなコードで部品の管理をしています。条件が多くて少し複雑になっています。
とりあえずは、うまくできました。J列の結果だけが、うまくできません。
但し、J列の結果が(38はローズ )の表示がうまくいきません。(6の黄色)になってしまいます。
要するに、J列の結果が不がローズ色で、合が白色で、欠が薄いオレンジ色になればよいということなのです。
原因が分からず困ってしまって、お聞きする次第です。回答して頂けるものでしようか。
ご教授下されば幸いに存じます。よろしくお願いします。
Macro2 Macro
マクロ記録日 :
'
Sheets("sheet1").Select
Columns("A:J").Select
Selection.Copy
Sheets("sheet2").Select
Columns("A:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Dim i As Long, LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("J2:J" & LastRow).ClearContents '← E2:Jにすると、欠に全部なります、この設定もおかしいように思いますが?
Range("E2:J" & LastRow).Interior.ColorIndex = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'文言の詳細について
'部品名と詳細-------------------------------------略称
'ghyu--------------------------------------←E列
'klub---------------------------------------←F列
'llpo----------------------------------------←G列
'合計個数(合計)-------------------------←H列 合計
'数量順位---------------------------------←I列 順位
'合格・不合格(合・不)欠品(欠)-----←J列 合・不・欠
If Cells(i, "E") >= 1 And Cells(i, "E") < 20 Then
Cells(i, "E").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "F") >= 1 And Cells(i, "F") < 6 Then
Cells(i, "F").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "F") >= 6 And Cells(i, "F") < 10 Then
Cells(i, "F").Interior.ColorIndex = 34 '34は 淡い青色
End If
If Cells(i, "G") >= 1 And Cells(i, "G") < 10 Then
Cells(i, "G").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "H") >= 1 And Cells(i, "H") <= 49 Then
Cells(i, "H").Interior.ColorIndex = 4 ' 4は うぐいす色
End If
If Cells(i, "J") >= "不" Then
Cells(i, "J").Interior.ColorIndex = 38 '38は ローズ
End If
If Cells(i, "J") >= "合" Then
Cells(i, "J").Interior.ColorIndex = 2 ' 2は 白色
End If
For j = 5 To 9 'D-F
If Cells(i, j).Value = 0 Then
Cells(i, j).Interior.ColorIndex = 3 '3は 赤色
ElseIf Cells(i, j).Value = "欠" Then
Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色
End If
Next j
For k = 5 To 9 'G-I
If Cells(i, j).Value = "欠" Then
Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色
End If
Next k
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
下記のようなコードで部品の管理をしています。条件が多くて少し複雑になっています。
とりあえずは、うまくできました。J列の結果だけが、うまくできません。
但し、J列の結果が(38はローズ )の表示がうまくいきません。(6の黄色)になってしまいます。
要するに、J列の結果が不がローズ色で、合が白色で、欠が薄いオレンジ色になればよいということなのです。
原因が分からず困ってしまって、お聞きする次第です。回答して頂けるものでしようか。
ご教授下されば幸いに存じます。よろしくお願いします。
Macro2 Macro
マクロ記録日 :
'
Sheets("sheet1").Select
Columns("A:J").Select
Selection.Copy
Sheets("sheet2").Select
Columns("A:J").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Dim i As Long, LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("J2:J" & LastRow).ClearContents '← E2:Jにすると、欠に全部なります、この設定もおかしいように思いますが?
Range("E2:J" & LastRow).Interior.ColorIndex = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'文言の詳細について
'部品名と詳細-------------------------------------略称
'ghyu--------------------------------------←E列
'klub---------------------------------------←F列
'llpo----------------------------------------←G列
'合計個数(合計)-------------------------←H列 合計
'数量順位---------------------------------←I列 順位
'合格・不合格(合・不)欠品(欠)-----←J列 合・不・欠
If Cells(i, "E") >= 1 And Cells(i, "E") < 20 Then
Cells(i, "E").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "F") >= 1 And Cells(i, "F") < 6 Then
Cells(i, "F").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "F") >= 6 And Cells(i, "F") < 10 Then
Cells(i, "F").Interior.ColorIndex = 34 '34は 淡い青色
End If
If Cells(i, "G") >= 1 And Cells(i, "G") < 10 Then
Cells(i, "G").Interior.ColorIndex = 6 ' 6は 黄色
End If
If Cells(i, "H") >= 1 And Cells(i, "H") <= 49 Then
Cells(i, "H").Interior.ColorIndex = 4 ' 4は うぐいす色
End If
If Cells(i, "J") >= "不" Then
Cells(i, "J").Interior.ColorIndex = 38 '38は ローズ
End If
If Cells(i, "J") >= "合" Then
Cells(i, "J").Interior.ColorIndex = 2 ' 2は 白色
End If
For j = 5 To 9 'D-F
If Cells(i, j).Value = 0 Then
Cells(i, j).Interior.ColorIndex = 3 '3は 赤色
ElseIf Cells(i, j).Value = "欠" Then
Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色
End If
Next j
For k = 5 To 9 'G-I
If Cells(i, j).Value = "欠" Then
Cells(i, j).Interior.ColorIndex = 45 '45は 薄いオレンジ色
End If
Next k
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
以前にマクロの記述について教えて頂いた件の続きになります．
ご指導頂いたとおりExcelマクロで複素数を扱う関数を下記HPから
標準モジュールにコピペしました．今度は正しくコピーできたと思いますが，
実行するとエラーになります．
標準の組込み関数を用いて「実数」の行列を計算すれば正しく
計算できますが，当然ながら「複素数」は計算できません．
この「複素数」を扱う新しく定義した関数が動かない理由，
「End if に対するifブロックがありません」とか
計算結果が「#VALUE!」となってしまうのは何故でしょうか？
マクロの記述内容はほとんど理解できないのですが，
どなたか助けて頂けませんか！
ちなみにエクセルは2016版です．
http://www.geocities.jp/tomtomf/denki/AC2/ac2.htm
http://www.geocities.jp/tomtomf/denki/AC1/ac1.htm
以下はコピー定義した「 IMMULT」関数と「 IMINVERS」関数のマクロです．
Public Function IMMULT(a As Range, b As Range) As Variant
Dim r1 As Integer, r2 As Integer, c1 As Integer, c2 As Integer, nn As Integer
Dim r As Integer, c As Integer
Dim cr As Integer, cc As Integer
Dim n As Integer
Dim mm() As Variant
r1 = a.Rows.Count
r2 = b.Rows.Count
c1 = a.Columns.Count
c2 = b.Columns.Count
If (c1 = r2) Then
nn = c1
Else
Exit Function
End If
cr = r1
cc = c2
ReDim mm(1 To cr, 1 To cc)
For r = 1 To cr
For c = 1 To cc
mm(r, c) = 0
For n = 1 To nn
mm(r, c) = IMSUMa(mm(r, c), IMPRODUCTa(a.Cells(r, n), b.Cells(n, c)))
Next
Next
Next
IMMULT = mm
End Function
Public Function IMINVERS(a As Range) As Variant
Dim n As Integer, n1 As Integer, n2 As Integer
Dim r1 As Integer, r2 As Integer, c As Integer
Dim max As Variant
Dim i As Integer
Dim m() As Variant
Dim inm() As Variant
Dim rr As Integer, cc As Integer
Dim no As Integer, ex As Variant
n1 = a.Rows.Count
n2 = a.Columns.Count
n = n1
ReDim inm(1 To n1, 1 To n2)
For rr = 1 To n1
For cc = 1 To n2
If rr <> cc Then inm(rr, cc) = 0 Else inm(rr, cc) = 1
'End If
Next
Next
ReDim m(1 To n1, 1 To n2)
m = a
If n1 <> n2 Then IMINVERS = False
Exit Function
End If
For r1 = 1 To n
max = m(r1, r1)
no = r1
If r1 < n Then
For i = r1 + 1 To n
If IMABSa(m(i, r1)) > IMABSa(max) Then max = m(i, r1)
no = i
End If
Next
If (r1 <> no) Then
For i = 1 To n
ex = m(r1, i)
m(r1, i) = m(no, i)
m(no, i) = ex
Debug.Print m(r1, i), m(no, i)
ex = inm(r1, i)
inm(r1, i) = inm(no, i)
inm(no, i) = ex
Next
End If
End If
max = m(r1, r1)
For i = 1 To n
m(r1, i) = IMDIVa(m(r1, i), max)
inm(r1, i) = IMDIVa(inm(r1, i), max)
Next
For r2 = 1 To n
If r1 <> r2 Then
max = m(r2, r1)
For i = 1 To n
m(r2, i) = IMSUBa(m(r2, i), IMPRODUCTa(m(r1, i), max))
inm(r2, i) = IMSUBa(inm(r2, i), IMPRODUCTa(inm(r1, i), max))
Next
End If
Next
Next
IMINVERS = inm
End Function
以下のような、サイトでコードをみつけました。今ひとつ、分からないことがあります。お教え下さいませんか。
やりたい元のデーターと抽出先について
sheet１の元データーはA列～G列のデーターです。sheet１のA列・B列・D列・E列・G列だけを抽出して、sheet２に表示させたいのです。なお、sheet１には、関数が入っています。
以下はサイトからのものです。
実行結果（1列目と3列目を抽出）
Sub 列抽出()
Dim データ範囲 As Range
Dim 抽出列 As Variant
Dim i As Long
Set データ範囲 = ActiveSheet.Range("A1").CurrentRegion
抽出列 = Array(1, 3)
Sheets.Add.Name = "抽出"
For i = 0 To UBound(抽出列)
データ範囲.Columns(抽出列(i)).Copy Sheets("抽出").Range("A1").Offset(0, i)
Next i
End Sub
以下のような、サイトでコードをみつけました。今ひとつ、分からないことがあります。お教え下さいませんか。
やりたい元のデーターと抽出先について
sheet１の元データーはA列～G列のデーターです。sheet１のA列・B列・D列・E列・G列だけを抽出して、sheet２に表示させたいのです。なお、sheet１には、関数が入っています。
以下はサイトからのものです。
実行結果（1列目と3列目を抽出）
Sub 列抽出()
Dim データ範囲 As Range
Dim 抽出列 As Variant
Dim i As Long
Set データ範囲 = ActiveSheet.Range("A1").CurrentRegion
抽出列 = Array(1, 3)
Sheets.Add.Name = "抽出"
For i = 0 To UBound(抽出列)
データ範囲.Columns(抽出列(i)).Copy Sheets("抽出").Range("A1").Offset(0, i)
Next i
End Sub
