VBA – VBA SQL

Option Compare Database
Private aryxml() As String
Private ixml As Long

Public Function parsexml()
Dim XML
Dim strfilepath As String
Dim returnary As Variant
Dim returnvalue As Integer

WizHook.Key = 51488399
returnvalue = WizHook.GetFileName(0, "", "", "", strfilepath, "", "すべてのファイル (*.*)|*.*", 0, 0, 8, True)
WizHook.Key = 0

returnary = Array(returnvalue, strfilepath)

If returnary(0) = -302 Then
    Exit function
End If

if not instr(returnary(1),chr(9))=0 then
 MsgBox “選択は一つにお願いします。”
 Exit function
End if

'Debug.Print returnary(1)

Set XML = CreateObject("MSXML2.DOMDocument.6.0")
XML.Load (returnary(1))
 
If (XML.parseerror.errorcode <> 0) Then
    MsgBox XML.parseerror.reason, vbCritical
End If

ixml = 0
    
Call getchildren(XML)

'Debug.Print "ubound " & UBound(aryxml, 2)
'Debug.Print aryxml(0, 0) & " " & aryxml(0, 1) & " " & aryxml(0, 2)
'Debug.Print aryxml(1, 0) & " " & aryxml(1, 1) & " " & aryxml(1, 2)
Set XML = Nothing
‘Erase aryxml

End Function

Private Function getchildren(xmlparent As Variant)
On Error Resume Next

Dim e

For Each e In xmlparent.childnodes
    If e.childnodes.length = 0 Then
        If Not xmlparent.basename = "" Then
                ReDim Preserve aryxml(1, ixml)
                    aryxml(0, ixml) = xmlparent.basename
                    aryxml(1, ixml) = e.text
        End If
    Else
        Call getchildren(e)
    End If
Next
ixml = ixml + 1

End Function

Option Compare Database

Private aryxml() As String

Private ixml As Long

Public Function parsexml()

Dim XML

Dim strfilepath As String

Dim returnary As Variant

Dim returnvalue As Integer

WizHook.Key = 51488399

returnvalue = WizHook.GetFileName(0, "", "", "", strfilepath, "", "すべてのファイル (*.*)|*.*", 0, 0, 8, True)

WizHook.Key = 0

returnary = Array(returnvalue, strfilepath)

If returnary(0) = -302 Then

Exit function

End If

if not instr(returnary(1),chr(9))=0 then

MsgBox “選択は一つにお願いします。”

Exit function

End if

'Debug.Print returnary(1)

Set XML = CreateObject("MSXML2.DOMDocument.6.0")

XML.Load (returnary(1))

If (XML.parseerror.errorcode <> 0) Then

MsgBox XML.parseerror.reason, vbCritical

End If

ixml = 0

Call getchildren(XML)

'Debug.Print "ubound " & UBound(aryxml, 2)

'Debug.Print aryxml(0, 0) & " " & aryxml(0, 1) & " " & aryxml(0, 2)

'Debug.Print aryxml(1, 0) & " " & aryxml(1, 1) & " " & aryxml(1, 2)

Set XML = Nothing

‘Erase aryxml

End Function

Private Function getchildren(xmlparent As Variant)

On Error Resume Next

Dim e

For Each e In xmlparent.childnodes

If e.childnodes.length = 0 Then

If Not xmlparent.basename = "" Then

ReDim Preserve aryxml(1, ixml)

aryxml(0, ixml) = xmlparent.basename

aryxml(1, ixml) = e.text

End If

Else

Call getchildren(e)

End If

ixml = ixml + 1

End Function

2020年5月23日2020年5月23日

recordsetclone

先日、accessのフォームを作成中
表示されたデータでテーブルを更新しようと・・。

ソースのクエリが複雑で面倒くさい。
フォームの値をそのまま使おうと、こういう時はme.recordsetだよなと・・

しかし動作時にカーソルが動きすぎてみっともない。で、この時ハッとrecordsetcloneてこういう時のためににあるのかな？と気が付きました。

違っているかもしれないですが書き留めておきます。

2020年4月21日2020年5月23日

format関数（3回目ぐらい）

format関数はvba、SqlServer、VB.netにありますが少し入力値に違いありです

vbaは文字でも数字でも日付型でも良いみたい
format(“41″,”000”) は041
だけど
SqlServer、VB.netの入力値は数字または日付型のみ許されるようです。
sqlserverでは
format(cast(’41’ as int),’000′)
としないと思った通りに返ってこない

知らなかったがVBAで
strconv(“abc”,vbUpperCase)　は　ABC　だけど
format(“abc”,”>”) 　も　ABC
知らなくても良さそうだが書いておきます。

2020年1月29日2020年6月29日

VBAからExcelを操作2

前回の

            Call Ary関数
            For j = 0 To UBound(Ary関数, 1)
 
                For I = 1 To UBound(Ary関数, 2)
                    objCells(j + 1, I + 2) = Ary関数(j, I)
                Next
            Next

Call Ary関数

For j = 0 To UBound(Ary関数, 1)

For I = 1 To UBound(Ary関数, 2)

objCells(j + 1, I + 2) = Ary関数(j, I)

この部分耐えがたい遅さです。
vb.netの二次元配列はまあまあ我慢できますがVBAはデータが多くなるとだめです。
一次元目の要素（項目数）が少なければ一次元配列を並べた方が速いです。
さらに速いのはレコードセットから直接ループさせつつ書き込む。
すごく速いのでvb.netもデータテーブルから直接書き込むようにしました。
プロセスも今の所残っていません。コードが冗長になりますけど。

2020年1月25日2020年6月29日

VBAからExcelを操作

VBAからもできるでしょうと思ったけど・・

    Public Function Excelbinding()
        Dim objExcel As Object
        Dim objExApp As Object

        Dim objWorkbook As Object
        Dim objWorkbooks As Object
        Dim fpath As String
        fpath = "xlsファイルのパス"

        Dim objSheets As Object
        Dim objSheet1 As Object
        Dim objSheet2 As Object
        Dim objSheet3 As Object
        Dim objCells As Object
        Dim I As Integer
        Dim j As Integer
            Set objExcel = CreateObject("Excel.Application")
            Set objExApp = objExcel.Application
            objExApp.Visible = True
            Set objWorkbooks = objExApp.Workbooks
            Set objWorkbook = objWorkbooks.Open(fpath)
            objExcel.DisplayAlerts = False
            'System.Threading.Thread.Sleep(5000)
            Set objSheets = objExApp.Sheets
            Set objSheet1 = objSheets(1)
            objSheet1.Delete
           
            Set objSheet1 = objSheets(1)
            Set objSheet2 = objSheets("シート名")
            objSheet2.Copy Before:=objSheet1
            Set objSheet3 = objSheets("シート名 (2)")　'前回と同じコピーに流し込む
            Set objCells = objSheet3.Cells

            Call Ary関数
            For j = 0 To UBound(Ary関数, 1)

                For I = 1 To UBound(Ary関数, 2)
                    objCells(j + 1, I + 2) = Ary関数(j, I)
                Next
            Next          
            objWorkbook.SaveAs (fpath)


            objExApp.Quit
            objExcel.DisplayAlerts = True

            Set objCells = Nothing
            Set objSheets = Nothing
            Set objSheet1 = Nothing
            Set objSheet2 = Nothing
            Set objSheet3 = Nothing
            Set objWorkbook = Nothing
            Set objWorkbooks = Nothing
            Set objExApp = Nothing
            Set objExcel = Nothing
end function

Public Function Excelbinding()

Dim objExcel As Object

Dim objExApp As Object

Dim objWorkbook As Object

Dim objWorkbooks As Object

Dim fpath As String

fpath = "xlsファイルのパス"

Dim objSheets As Object

Dim objSheet1 As Object

Dim objSheet2 As Object

Dim objSheet3 As Object

Dim objCells As Object

Dim I As Integer

Dim j As Integer

Set objExcel = CreateObject("Excel.Application")

Set objExApp = objExcel.Application

objExApp.Visible = True

Set objWorkbooks = objExApp.Workbooks

Set objWorkbook = objWorkbooks.Open(fpath)

objExcel.DisplayAlerts = False

'System.Threading.Thread.Sleep(5000)

Set objSheets = objExApp.Sheets

Set objSheet1 = objSheets(1)

objSheet1.Delete

Set objSheet1 = objSheets(1)

Set objSheet2 = objSheets("シート名")

objSheet2.Copy Before:=objSheet1

Set objSheet3 = objSheets("シート名 (2)")　'前回と同じコピーに流し込む

Set objCells = objSheet3.Cells

Call Ary関数

For j = 0 To UBound(Ary関数, 1)

For I = 1 To UBound(Ary関数, 2)

objCells(j + 1, I + 2) = Ary関数(j, I)

objWorkbook.SaveAs (fpath)

objExApp.Quit

objExcel.DisplayAlerts = True

Set objCells = Nothing

Set objSheets = Nothing

Set objSheet1 = Nothing

Set objSheet2 = Nothing

Set objSheet3 = Nothing

Set objWorkbook = Nothing

Set objWorkbooks = Nothing

Set objExApp = Nothing

Set objExcel = Nothing

end function

今までは意識してなかったけどVBAではオブジェクト解放は要らない？
プロセスは残らないが・・
とりあえずset=nothingで安心することに。

2019年7月24日2019年7月30日

選択ソート　二次元配列

ついでに選択ソートも

Dim Ary() As String
For I = 0 To myDIC.Count - 1
ReDim Preserve Ary(1, I)
    Ary(0, I) = myDIC.keys()(I)
    Ary(1, I) = myDIC.items()(I)
Next I
'Dictionaryから二次元配列に
'以下ソート
Dim i As Long, j As Long
Dim Max As Double, flag As Double
Dim newA0 As Long, newB0 As Long _
, newA1 As Double, newB1 As Double, Mark As Long

For I = 0 To UBound(Ary, 2) - 1
    flag = CDbl(Ary(1, I))
    Max = CDbl(Ary(1, I))
    Mark = I

    For j = 1 To UBound(Ary, 2) - I
        If Max < CDbl(Ary(1, I + j)) Then
            Max = CDbl(Ary(1, I + j))
            Mark = I + j
        End If
    Next j

    newA0 = Ary(0, Mark)
    newA1 = CStr(Max)
    newB0 = Ary(0, I)
    newB1 = CStr(flag)

If Not Mark = I Then
    Ary(0, I) = newA0
    Ary(1, I) = newA1
    Ary(0, Mark) = newB0
    Ary(1, Mark) = newB1
End If
Next I

Dim Ary() As String

For I = 0 To myDIC.Count - 1

ReDim Preserve Ary(1, I)

Ary(0, I) = myDIC.keys()(I)

Ary(1, I) = myDIC.items()(I)

Next I

'Dictionaryから二次元配列に

'以下ソート

Dim i As Long, j As Long

Dim Max As Double, flag As Double

Dim newA0 As Long, newB0 As Long _

, newA1 As Double, newB1 As Double, Mark As Long

For I = 0 To UBound(Ary, 2) - 1

flag = CDbl(Ary(1, I))

Max = CDbl(Ary(1, I))

Mark = I

For j = 1 To UBound(Ary, 2) - I

If Max < CDbl(Ary(1, I + j)) Then

Max = CDbl(Ary(1, I + j))

Mark = I + j

End If

Next j

newA0 = Ary(0, Mark)

newA1 = CStr(Max)

newB0 = Ary(0, I)

newB1 = CStr(flag)

If Not Mark = I Then

Ary(0, I) = newA0

Ary(1, I) = newA1

Ary(0, Mark) = newB0

Ary(1, Mark) = newB1

End If

Next I

2019年7月24日2019年8月21日

QuickSort 二次元配列

もともとはDictionaryでソートする必要があったので配列のソートを調べたのでした
dictionaryに入っているkeyとitemを二次元配列にしてソートする
もっと良い方法があると思いますが・・とりあえず
関数化したけど要素で型変換必要なので意味がなかった

Public Function QuickSortB(ByRef ParamAry As Variant) As Variant

'paramaryは二次元配列

Dim newAry() As String
Dim I As Long
Dim j As Long
Dim K As Long
Dim Anker As Date　'ソートしたい
Dim Bnker As Long

Dim TopAry() As String
Dim BtmAry() As String
j = 0
K = 0

If Not UBound(ParamAry, 2) >= 0 Then 'トラップ
Exit Function
End If

    Bnker = CLng(ParamAry(0, 0))　
    Anker = CDate(ParamAry(1, 0))　
For I = 1 To UBound(ParamAry, 2)

    If CDate(ParamAry(1, I)) < Anker Then
        ReDim Preserve TopAry(1, j)
        TopAry(0, j) = ParamAry(0, I)
        TopAry(1, j) = ParamAry(1, I)

        j = j + 1

    End If

    If CDate(ParamAry(1, I)) >= Anker Then
        ReDim Preserve BtmAry(1, K)
        BtmAry(0, K) = ParamAry(0, I)
        BtmAry(1, K) = ParamAry(1, I)
        K = K + 1
    End If
Next I

Dim n As Long
n = 0
If j &gt; 0 Then
    TopAry = QuickSortB(TopAry)
    For I = 0 To UBound(TopAry, 2)
        ReDim Preserve newAry(1, n)
        newAry(0, n) = TopAry(0, I)
        newAry(1, n) = TopAry(1, I)

        n = n + 1
    Next I
End If
        ReDim Preserve newAry(1, n)
        newAry(0, n) = Bnker
        newAry(1, n) = Anker
        
        n = n + 1
If K &gt; 0 Then
    BtmAry = QuickSortB(BtmAry)
    For I = 0 To UBound(BtmAry, 2)
        ReDim Preserve newAry(1, n)
        newAry(0, n) = BtmAry(0, I)
        newAry(1, n) = BtmAry(1, I)
        n = n + 1
    Next I
End If
QuickSortB = newAry

End Function

Public Function QuickSortB(ByRef ParamAry As Variant) As Variant

'paramaryは二次元配列

Dim newAry() As String

Dim I As Long

Dim j As Long

Dim K As Long

Dim Anker As Date　'ソートしたい

Dim Bnker As Long

Dim TopAry() As String

Dim BtmAry() As String

j = 0

K = 0

If Not UBound(ParamAry, 2) >= 0 Then 'トラップ

Exit Function

End If

Bnker = CLng(ParamAry(0, 0))　

Anker = CDate(ParamAry(1, 0))　

For I = 1 To UBound(ParamAry, 2)

If CDate(ParamAry(1, I)) < Anker Then

ReDim Preserve TopAry(1, j)

TopAry(0, j) = ParamAry(0, I)

TopAry(1, j) = ParamAry(1, I)

j = j + 1

End If

If CDate(ParamAry(1, I)) >= Anker Then

ReDim Preserve BtmAry(1, K)

BtmAry(0, K) = ParamAry(0, I)

BtmAry(1, K) = ParamAry(1, I)

K = K + 1

End If

Next I

Dim n As Long

n = 0

If j > 0 Then

TopAry = QuickSortB(TopAry)

For I = 0 To UBound(TopAry, 2)

ReDim Preserve newAry(1, n)

newAry(0, n) = TopAry(0, I)

newAry(1, n) = TopAry(1, I)

n = n + 1

Next I

End If

ReDim Preserve newAry(1, n)

newAry(0, n) = Bnker

newAry(1, n) = Anker

n = n + 1

If K > 0 Then

BtmAry = QuickSortB(BtmAry)

For I = 0 To UBound(BtmAry, 2)

ReDim Preserve newAry(1, n)

newAry(0, n) = BtmAry(0, I)

newAry(1, n) = BtmAry(1, I)

n = n + 1

Next I

End If

QuickSortB = newAry

End Function

2019年7月9日2020年6月24日

VBAで配列をソート　テーブルを使う

テーブルに入れると言う手もあります
これが一番簡単
SQLserverとつながっているなら一時テーブルに入れ込む

Public Function TableSort(Ary As Variant) As Variant
'Dim Ary
'Ary = Array("5", "4", "1", "2", "900", "888")

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.ConnectionString = "接続文字列"
cn.Open

Dim I As Long
I = 0
cn.Execute "drop table if exists #AryT"
cn.Execute "select " & CLng(Ary(I)) & "as C into #AryT"

For I = 1 To UBound(Ary)
    cn.Execute "insert into #AryT(C) values(" & CLng(Ary(I)) & ")"
Next I

rs.Open "select C from #AryT order by C asc", cn, adOpenStatic, adLockOptimistic

rs.MoveFirst

I = 0
Do Until rs.EOF
    Ary(I) = rs!C
    rs.MoveNext
    I = I + 1
Loop

'For I = 0 To UBound(Ary)
'    Debug.Print Ary(I)
'Next

TableSort = Ary

 rs.Close
 cn.Close

End Function

Public Function TableSort(Ary As Variant) As Variant

'Dim Ary

'Ary = Array("5", "4", "1", "2", "900", "888")

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Set cn = New ADODB.Connection

Set rs = New ADODB.Recordset

cn.ConnectionString = "接続文字列"

cn.Open

Dim I As Long

I = 0

cn.Execute "drop table if exists #AryT"

cn.Execute "select " & CLng(Ary(I)) & "as C into #AryT"

For I = 1 To UBound(Ary)

cn.Execute "insert into #AryT(C) values(" & CLng(Ary(I)) & ")"

Next I

rs.Open "select C from #AryT order by C asc", cn, adOpenStatic, adLockOptimistic

rs.MoveFirst

I = 0

Do Until rs.EOF

Ary(I) = rs!C

rs.MoveNext

I = I + 1

Loop

'For I = 0 To UBound(Ary)

' Debug.Print Ary(I)

'Next

TableSort = Ary

rs.Close

cn.Close

End Function

月	火	水	木	金	土	日
« 11月
1	2	3	4	5	6	7
8	9	10	11	12	13	14
15	16	17	18	19	20	21
22	23	24	25	26	27	28
29	30