Sub PasswordBreaker() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Subここ参照
2019年10月4日金曜日
シート保護掛けたが、パスワードを忘れてしまいました？ハッキング方法
下記のソースコードを解除したいシートにコピーして、実行するだけ…
2019年7月2日火曜日
左に列の合計,FormulaLocalの書き方
ラベル:
formual,
FormulaLocal,
vba
cl.Offset(0, 3).FormulaLocal = "=SUM(RC[-2],RC[-1])"
2019年7月1日月曜日
vlookupではできない、範囲指定のカスタマイズ関数
Function vlookups(val As Range, min As Range, max As Range, col As Range) As String
Dim cl As Range
For Each cl In min
If val.Value >= cl.Value And val.Value <= cl.Worksheet.Cells(cl.Row, max.Column) Then
vlookups = cl.Worksheet.Cells(cl.Row, col.Column)
Exit For
End If
Next
End Function
使い方：
=vlookups(E4,$A$1:$A$4,$B$1:$B$4,$C$1:$C$4)
結果：
2019年5月10日金曜日
令和数式を置換してくれる自作関数
ポイントは正規表現のReplaceで、パターン化して一致されたセルの番地を更にReplaceに使ったこと。「$1」を使って一個目のマッチングを引用すること。
Option Explicit
Public Const REIWA = "IF(_CELL_>=DATE(2019,5,1),""令和""&IF(YEAR(_CELL_)-2018=1,""元"",YEAR(_CELL_)-2018)&""年""&MONTH(_CELL_)&""月""&DAY(_CELL_)&""日"",TEXT(_CELL_,""ggge年m月d日""))"
Function reiwa_switch(strFormual, strCellAddr As String) As String
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = "TEXT\((" & strCellAddr & "),""ggge年m月d日""\)"
.IgnoreCase = False
.Global = True
End With
reiwa_switch = reg.Replace(strFormual, Replace(REIWA, "_CELL_", "$1"))
End Function
=reiwa_switch(A1,A2)→関数
TEXT(data!FU3,"ggge年m月d日")→第一引数（A1）
data!FU3→第二引数（A2）
IF(data!FU3>=DATE(2019,5,1),"令和"&IF(YEAR(data!FU3)-2018=1,"元",YEAR(data!FU3)-2018)&"年"&MONTH(data!FU3)&"月"&DAY(data!FU3)&"日",TEXT(data!FU3,"ggge年m月d日"))→結果
2018年8月2日木曜日
複数PDFを一括印刷する、PDF毎の一枚目は飛ばす。ドラッグアンドドロップ
ラベル:
javascript,
pdf,
vba,
vbs
'//Bath Print multiple pdfs without the first page
'//複数PDFを一括印刷する、PDF毎の一枚目は飛ばす。ドラッグアンドドロップでできます
set WshShell = CreateObject ("Wscript.Shell")
set fs = CreateObject("Scripting.FileSystemObject")
Set objArgs = WScript.Arguments
if objArgs.Count < 1 then
msgbox("Please drag a file on the script")
WScript.quit
end if
Set gApp = CreateObject("AcroExch.App")
gApp.show '<- br="" comment="" hidden="" in="" mod="" or="" out="" take="" to="" work="">
'open via Avdoc and print
for i=0 to objArgs.Count - 1
FileIn = ObjArgs(i)
Set AVDoc = CreateObject("AcroExch.AVDoc")
If AVDoc.Open(FileIn, "") Then
Set PDDoc = AVDoc.GetPDDoc()
Set JSO = PDDoc.GetJSObject
x = PDDoc.GetNumPages
jso.print false, 1, x-1, true
gApp.CloseAllDocs
end if
next
gApp.hide : gApp.exit : Quit()
MsgBox "Done!"
Sub Quit
Set JSO = Nothing : Set PDDoc = Nothing : Set gApp =Nothing : Wscript.quit
End Sub
2018年6月29日金曜日
同じ時刻じゃないの？！！という罠
?cdate("2014/01/02 16:05:00") = dateadd("n",5,cdate("2014/01/02 16:00:00"))
False
?cdate("2014/01/02 16:05:00") - dateadd("n",5,cdate("2014/01/02 16:00:00"))
7.27595761418343E-12
おかしいでしょう！ 16:05:00は16:00:00に5分足すじゃない！
参考ここ：
https://www.reddit.com/r/vba/comments/5mdnpb/pic_of_my_data_mismatch_problem/
http://www.fmsinc.com/tpapers/math/index.html
DateDiff("s", cdate("2014/01/02 16:05:00"), dateadd("n",5,cdate("2014/01/02 16:00:00"))) = 0
2017年9月7日木曜日
「_xlfn.IFERROR」という #NAME?エラー見えない「名前定義」にエラーがあった場合
下記の王なメソッドを作って、一旦エラーになっている名前定義を見える化にして、そして「名前」一覧から手動で削除して、ブックを保存
Sub delErrNames()
Dim n As name
Dim bk As Workbook
Set bk = ThisWorkbook
For Each n In bk.Names
If n.RefersTo = "=#NAME?" Then
n.Visible = True
End If
Next
End Sub
2017年6月9日金曜日
GHOST BREAKPOINT,VBA ブレークポイント設置してないのに、急にいちいち止まるようになる件
解決方法
１．Debugに入って（そもそも止まらないなら、とりあえずなんかのsubを作成して、PBを置いて止める）
２．Ctrl+Pauseを2回押す
３．Playで継続
４．保存
１．Debugに入って（そもそも止まらないなら、とりあえずなんかのsubを作成して、PBを置いて止める）
２．Ctrl+Pauseを2回押す
３．Playで継続
４．保存
2017年4月27日木曜日
PHONETIC関数が効かない時
PHONETICという漢字をカタカナに変換してくれる関数があります。しかし何故か変換せれず漢字のまま出力されてしまう時があります。
その時は、マクロのチカラを借りる。
例えば漢字の列がA列の場合：
実行後、隣の列で「=PHONETIC("A1")」で数式を入れると変換されます
その時は、マクロのチカラを借りる。
例えば漢字の列がA列の場合：
Range("A:A").SetPhonetic
実行後、隣の列で「=PHONETIC("A1")」で数式を入れると変換されます
2017年3月30日木曜日
ListBoxがマウスのスクロール対応していない？！
やってみたら本当だ。
幸いソリューションは既にありました。ありがとうございます。
参照： https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
幸いソリューションは既にありました。ありがとうございます。
参照： https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
Private Sub ListBox1_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
' start tthe hook
HookListBoxScroll
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
''''''' end Userform code
''''''' normal module code
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
2017年3月15日水曜日
2017年2月15日水曜日
VBA Arrayの論理計算、交集、並集（AND OR）（Intersection And Union）（Logical disjunction Logical conjunction）
Option Explicit
Sub testUnionAndIntersection()
'Intersection And Union
'Also called
'Logical disjunction Logical conjunction
'AND OR
Dim a As New Scripting.Dictionary
Dim b As New Scripting.Dictionary
Dim keysA As Variant
Dim keysB As Variant
Dim keysC As Variant
Dim keysD As Variant
a.Add "A", ""
a.Add "B", ""
a.Add "C", ""
b.Add "A", ""
b.Add "C", ""
b.Add "X", ""
keysA = a.Keys
keysB = b.Keys
keysC = getIntersectionSet(keysA, keysB)
Debug.Print Join(keysC, ",")
'A,C
keysD = getUnionSet(keysA, keysB)
Debug.Print Join(keysD, ",")
'A,B,C,X
Call DeleteElementAt(1, keysB)
Debug.Print Join(keysB, ",")
'A,X
End Sub
Function getIntersectionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant
If Not (IsArray(arr1) And IsArray(arr2)) Then
Exit Function
End If
For Each vntTmp In arr1
If IsInArray(CStr(vntTmp), arr2) Then
push vntTmp, vntRst
End If
Next
getIntersectionSet = vntRst
End Function
Function getUnionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant
If Not (IsArray(arr1) And IsArray(arr2)) Then
Exit Function
End If
vntRst = arr1
For Each vntTmp In arr2
If Not IsInArray(CStr(vntTmp), vntRst) Then
push vntTmp, vntRst
End If
Next
getUnionSet = vntRst
End Function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Public Sub DeleteElementAt(ByVal index As Integer, ByRef prLst As Variant)
Dim i As Integer
For i = index + 1 To UBound(prLst)
prLst(i - 1) = prLst(i)
Next
ReDim Preserve prLst(UBound(prLst) - 1)
End Sub
Public Function push(ByVal val As Variant, ByRef arr As Variant, Optional ByVal unique As Boolean = False) As Integer
Dim lngX As Long
If unique Then
If Not IsEmpty(arr) Then
If IsArray(arr) Then
For lngX = LBound(arr) To UBound(arr)
If arr(lngX) = val Then
push = UBound(arr)
Exit Function
End If
Next
End If
End If
End If
If IsArray(arr) Then
On Error GoTo initArray
ReDim Preserve arr(UBound(arr) + 1)
Else
initArray:
ReDim arr(0)
End If
If VarType(val) = 9 Then '9 is object
Set arr(UBound(arr)) = val
Else
arr(UBound(arr)) = val
End If
push = UBound(arr)
End Function
2016年12月6日火曜日
ADOレコーダーがあるのに、RecordCountが「-1」の場合の対処
レコーダーがあるのに、RecordCountが「-1」の場合の対処
connect.CursorLocation = 3 'クライアントカーソルにする
Set rs = execQuery(cn, sql, , adOpenKeyset, adLockOptimistic)
debug.print rs.RecordCount
2016年9月2日金曜日
列の値を一括更新（LOOP、Query、補助列を使わず！）
列の値を一括更新するときは、vbaで行ごとLOOPを書くか、ADODBでUpdateクエリーを書くか、補助列を挿入して数式で計算させるかでも、最近「Evaluate」知ったですよ
これは神メソッドですね。気を付けなければならないのは、空欄が0に評価されてしまう、数字以外の文字列がエラーになる。
メソッド化にすると
LOOP、Query、補助列を使わずに、"A1:A1000"列の数値を全部＊10.1,書式を小数点二桁にする
もう少し複雑な数式でもいけるらしい
Range("B:B").Value = Evaluate(Range("B:B").Address & "*10")
これは神メソッドですね。気を付けなければならないのは、空欄が0に評価されてしまう、数字以外の文字列がエラーになる。
メソッド化にすると
Sub updateRangeValues(ByRef rg As Range, strFormula As String, Optional strFormat As String = "")
rg.Worksheet.Activate '←ここが重要！！、なぜかこうしないと全部0と評価してしまう
If strFormat <> "" Then
rg.NumberFormatLocal = strFormat
End If
rg.Value = Application.Evaluate(rg.Address & strFormula)
Application.Calculate
Do While Application.CalculationState <> xlDone '←念のため、計算が終わまでDoEvents
DoEvents
Loop
End Sub
使い方：
Call updateRangeValues(Range("A1:A1000"),"*10.1","#.00")
LOOP、Query、補助列を使わずに、"A1:A1000"列の数値を全部＊10.1,書式を小数点二桁にする
もう少し複雑な数式でもいけるらしい
Sub nn()
Dim rg As Range
Set rg = ThisWorkbook.Worksheets(1).Range("C1:C36")
strFormula = "=IF(" & rg.Address & "= """",""IS EMPTY""," & rg.Address & "*10)"
rg.Value = Application.Evaluate(strFormula)
End Sub
2016年7月15日金曜日
2016年6月30日木曜日
VBAのRoundの罠
ROUND(38.5)
結果：38
ROUND(39.5)
結果：40
「銀行家の丸め (bankers' rounding)」、「銀行丸め」ともいう。
5が切り捨てられたり切り上げられたりするので「五捨五入」と呼ばれたり、
端数がちょうど0.5の場合に整数部分が偶数なら切り捨て奇数なら切り上げる
ので「偶捨奇入」と呼ばれたりもする。
本当の「四捨五入」したい場合は
WorksheetFunction.Round()
が有効だそうです。
しかし、ADODB,Jet.OLEDBなどでQuery（クエリー）で運用時は使えないので
sql = "UPDATE MyTable SET `Ammount` = ROUND(35*1.1)"
Call csv_cn.Execute(sql)
=ROUND(38.5) = 38
↓
sql = "UPDATE MyTable SET `Ammount` = FORMAT(35*1.1,""#"")"
Call csv_cn.Execute(sql)
=ROUND(38.5) = 39
ちなみに、小数点以下2位の四捨五入は
sql = "UPDATE MyTable SET `Ammount` = FORMAT(35*1.111,""#.00"")"
Call csv_cn.Execute(sql)
2016年6月24日金曜日
Scripting.Dictionaryのkeyまたはitemをindexで参照する方法
ラベル:
Scripting.Dictionary,
vba
Dim dic As New Scripting.Dictionary
dic.Add "a", "apple"
dic.Add "b", "banana"
'For Eachで
Dim vntKey As Variant
For Each vntKey In dic.Keys
Debug.Print vntKey & ":" & dic(vntKey)
Next
'または Forで
Dim intX As Integer
For intX = 0 To dic.Count - 1
Debug.Print dic.Keys(intX) & ":" & dic.Items(intX)
Next
'Indexで指定でもいい←これは面白い
Debug.Print dic.Keys()(0) & ":" & dic.Items()(0)
Debug.Print dic.Keys()(1) & ":" & dic.Items()(1)
'最後のkeyとvalue
Debug.Print dic.Keys()(dic.Count - 1) & ":" & dic.Items()(dic.Count - 1)
2015年3月12日木曜日
2014年11月7日金曜日
エクセルで右クリックが効かないときの対策
エクセルで右クリックが効かないときの対策
①エクセルを開いて
②Alt + F11押してVBEを出します
③Ctrl+Gでイミディエイトを出します
④下記をコピペして、Enterを押す
⑤Alt+Qでシートに戻る
シートタブの右クリックが無効になった場合の対策
方法はほぼ同じ、④番のコピペが下記に変更するだけ
①エクセルを開いて
②Alt + F11押してVBEを出します
③Ctrl+Gでイミディエイトを出します
④下記をコピペして、Enterを押す
Application.CommandBars("cell").Enabled = True
⑤Alt+Qでシートに戻る
シートタブの右クリックが無効になった場合の対策
方法はほぼ同じ、④番のコピペが下記に変更するだけ
Application.CommandBars("Ply").Enabled = True
2014年10月30日木曜日
VBAでクエリーが日本語を含めると結果が文字化ける件
Sub hh()
Dim sql As String
Dim rs As New ADODB.Recordset
Dim con As ADODB.Connection
Dim dbConnStr As String
dbConnStr = "Driver={MySQL ODBC 5.2 ANSI DRIVER}; SERVER=localhost; DATABASE=landscape; USER=root; PASSWORD=mypass;"
Set con = New ADODB.Connection
con.Open dbConnStr
sql = "SELECT '東京都' AS tokyou"
rs.Open sql, con
Debug.Print rs!tokyou
rs.Close
Set rs = Nothing
con.Close
Set con = Nothing
End Sub
結果表示
東・
ここでは「Driver={MySQL ODBC 5.2 ANSI DRIVER}」を「Driver={MySQL ODBC 5.2 UNICODE DRIVER}」に変更すればOK
また、「rs!tokyou」は「rs.Fields("tokyou")」で書いたほうがいいと思います。
登録:
投稿 (Atom)