2012年2月29日水曜日

vbaでエンコードがeucのファイルの処理

ラベル:
ADODB.Streamを利用して、vbaでエンコードがeucのファイルを処理する方法
Dim ADS As Object
Set ADS = CreateObject("ADODB.Stream")
Dim strText As String

'対象ファイルの状況によって、下記を使い分け
Const adTypeText = 2 'テキストファイル
Const adTypeBinary = 1 'バイナリファイル
Const adReadLine = -2 '行ごと読む
Const adReadAll = -1 'ファイル全体を読む
Const adLF = 10 '改行LF
Const adCR = 13 '改行CR
Const adCRLF = -1 '改行CRLF

With ADS
    .Open
    .Type = adTypeText
    .Charset = "EUC-JP" ' EUCコード
    .LineSeparator = adLF
    .LoadFromFile ファイル名 ' 読み込むファイルを指定
    .Position = 0 ' 読み込む位置は先頭から
    strText= .ReadText(adReadAll )
    .Close
End With
Debug.Print strText
投稿者 kg88 時刻: 15:40 0 コメント

2012年2月27日月曜日

特殊ディレクトリ一覧、XPとVISTA便利

便利ですよ、ありがとうございました。
引用元はhttp://pasofaq.jp/windows/mycomputer/folderlist.htm

名称 XP でのフォルダ Vista でのフォルダ
%USERPROFILE% C:\Documents and Settings\（ユーザー名） C:\Users\（ユーザー名）
%ALLUSERSPROFILE% C:\Documents and Settings\All Users C:\ProgramData
Application Data アプリケーションデータ %USERPROFILE%\Application Data %USERPROFILE%\AppData\Roaming
Cache キャッシュ %USERPROFILE%\Local Settings\ %USERPROFILE%\AppData\Local\
Temporary Internet Files Microsoft\Windows\
  Temporary Internet Files
Cookies クッキー %USERPROFILE%\Cookies %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\Cookies
Desktop デスクトップ %USERPROFILE%\デスクトップ %USERPROFILE%\Desktop
Favorites お気に入り %USERPROFILE%\Favorites
History インターネット履歴 %USERPROFILE%\Local Settings\History %USERPROFILE%\AppData\Local\
Microsoft\Windows\History
My Music [XP] マイ ミュージック %USERPROFILE%\My Documents\My Music %USERPROFILE%\Music
[Vista] ミュージック
My Pictures [XP] マイ ピクチャ %USERPROFILE%\My Documents\My Pictures %USERPROFILE%\Pictures
[Vista] ピクチャ
My Video [XP] マイ ビデオ %USERPROFILE%\My Documents\My Videos %USERPROFILE%\Videos
[Vista] ビデオ
NetHood 共有フォルダ履歴 %USERPROFILE%\NetHood %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\Network Shortcuts
Personal [XP] マイ ドキュメント %USERPROFILE%\My Documents %USERPROFILE%\Documents
[Vista] ドキュメント
PrintHood プリンタ フォルダ %USERPROFILE%\PrintHood %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\Printer Shortcuts
Programs プログラムメニュー %USERPROFILE%\スタート メニュー\プログラム %USERPROFILE%\AppData\Roaming\
（個人） Microsoft\Windows\Start Menu\Programs
プログラムメニュー %ALLUSERSPROFILE%\スタート メニュー\プログラム %ALLUSERSPROFILE%\Microsoft\
（全ユーザー） Windows\Start Menu\Programs
Recent [XP] 最近使ったファイル %USERPROFILE%\Recent %USERPROFILE%\AppData\Roaming\
[Vista] 最近使った項目 Microsoft\Windows\Recent
SendTo 送る %USERPROFILE%\SendTo %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\SendTo
Start Menu スタートメニュー %USERPROFILE%\スタート メニュー %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\Start Menu
Startup スタートアップ %USERPROFILE%\スタート メニュー\プログラム\ %USERPROFILE%\AppData\Roaming\
スタートアップ Microsoft\Windows\Start Menu\
  Programs\Startup
Templates テンプレート %USERPROFILE%\Templates %USERPROFILE%\AppData\Roaming\
Microsoft\Windows\Templates
投稿者 kg88 時刻: 16:42 0 コメント

2012年2月15日水曜日

vbaでExcelチャートを弄るサンプル

ラベル:
vbaでExcelチャートを弄る簡単サンプル
Dim chartObj As ChartObject
Dim myChart As Chart
        For Each chartObj In someSheet.ChartObjects
            Select Case chartObj.Chart.ChartTitle.Caption
                Case "株価の推移"
                    'なぜか直接chartObj.Chart.SeriesCollectionを参照するとエラー
                    '一旦Chartオブジェクトに参照を移す
                    Set myChart = chartObj.Chart
                    
                    With myChart.SeriesCollection(1) 
                        .XValues = "='共通データ'!$B$2:$B$10"
                        .Values = "='共通データ'!$C$2:$C$10"
                    End With
                
                Case "そのた"
                
            End Select
        Next
上の例はチャートのタイトルで判別する場合、チャートの名前で判断する場合は
Dim chartObj As ChartObject
    Select Case chartObj.Name

ちなみにchartObj.Nameはreadonlyの属性みたい。chartObj.Nameを変更したい場合はExcelのメニュー
レイアウト＞グラフ名で変更できます

投稿者 kg88 時刻: 18:01 0 コメント

2012年2月5日日曜日

自作VBAモジュール、特定のRangeをHashオブジェクトに格納するメソッドです。グループ分けのマスター／サブキーの設定も可能

ラベル: ,
自作モジュール、知る人ぞ知る、商用禁止
Option Explicit
'useage example:
'************************************************************************************
'load Microsoft scripting runtime
'dim result as Scripting.Dictionary
'set result = rg2hash(myWorksheet.Range("A2:CD255"), Array("term", "id") , True)
'************************************************************************************

'######################################################################################################################################################################################################
'rg2hash:               -- return an key formated hash that read from a certain range or Nothing if anything goes wrong
'author:                -- kagen.job$gmail.com write on 2102/2/5
'para1:rg               -- (must) an rectangle Range object to be read
'para2:keys             -- (opti - default Empty) an array of keys from main to sub such as array("Class","student","term","score"...),remember that first element of the array is the "master" key and others is the "sub" keys from big to small, and all the keys union should point to a unique record,if Empty will use the row number(string) as the master key and no sub keys
'para3:isFirstRowTitle  -- (opti - default True) falg if the first row of the rang is the title row,if True will use the title as item key (title should be unique), if False,will use the colume number(string) as the item key

'I made this to make it easy to get table into a easy "find" easy "reference" scripting dictionary object for vba developers
'######################################################################################################################################################################################################
Public Function rg2hash(ByVal rg As Range, Optional ByVal keys As Variant = Empty, Optional ByVal isFirstRowTitle As Boolean = True) As Scripting.Dictionary
    Dim dicHeader As New Scripting.Dictionary
    Dim dicHeaderRev As New Scripting.Dictionary
    Dim csvrow As Range
    Dim csvfield As Range
    Dim dicResult As New Scripting.Dictionary
    Dim key As Variant
    Dim keyVals As Variant
    Dim lngIndex As Long
    Dim refDic As Scripting.Dictionary
    
    
    'first removeall
    dicResult.RemoveAll
    
    If isFirstRowTitle Then
        'if only title row exit
        If Not rg.Rows.Count > 1 Then
            Set rg2hash = Nothing
            Exit Function
        End If
        For Each csvfield In rg.Rows(1).Columns
            'place keys
            If Not dicHeader.Exists(csvfield.Value) And Not IsEmpty(csvfield.Value) Then
                dicHeader.Add CStr(csvfield.Value), csvfield.Column
                dicHeaderRev.Add CStr(csvfield.Column), csvfield.Value
            Else
                'key should not be duplicated
                Set rg2hash = Nothing
                Exit Function
            End If
        Next
    Else
        For Each csvfield In rg.Rows(1).Columns
            'if no title row, column number will be the item keys
            dicHeader.Add CStr(csvfield.Column), csvfield.Column
            dicHeaderRev.Add CStr(csvfield.Column), csvfield.Column
        Next
    End If
    
    lngIndex = 1
    'begin to scan the range and read recorders
    For Each csvrow In rg.Rows
        'if first row is title skip it
        If lngIndex = 1 And isFirstRowTitle Then
        
        Else
            'make the {master key -> sub key1 -> sub key2 -> ... -> new dictionary object} strcture
            keyVals = Array()
            If Not IsEmpty(keys) Then
                If UBound(keys) >= 0 Then
                    For Each key In keys
                        push_ref CStr(Cells(csvrow.Row, dicHeader.Item(CStr(key))).Value), keyVals
                    Next
                End If
            Else
                'if no master/sub keys set, row index (start from 1) will be the master key and no sub keys
                push_ref CStr(IIf(isFirstRowTitle, lngIndex - 1, lngIndex)), keyVals
            End If
            Set refDic = buildDic(dicResult, keyVals)
            
            'at the last sub key position write the detail(item) records
            For Each csvfield In csvrow.Columns
                refDic.Add CStr(dicHeaderRev.Item(CStr(csvfield.Column))), csvfield.Value
            Next
            
        End If
        lngIndex = lngIndex + 1
    Next
    Set rg2hash = dicResult
    Set refDic = Nothing
    Set dicHeader = Nothing
    Set dicHeaderRev = Nothing
End Function
'this is a function to make a master-sub key strctured dictionary object and refer to the last sub key ready to put the detial record
Public Function buildDic(ByRef dic As Scripting.Dictionary, ByVal keys As Variant) As Scripting.Dictionary
    Dim key As Variant
    If UBound(keys) > 0 Then
        If Not dic.Exists(keys(LBound(keys))) Then
            dic.Add CStr(keys(LBound(keys))), New Scripting.Dictionary
        End If
        Set buildDic = buildDic(dic.Item(CStr(keys(LBound(keys)))), shift_ref(keys))
    ElseIf UBound(keys) = 0 Then
        dic.Add CStr(keys(0)), New Scripting.Dictionary
        Set buildDic = dic.Item(CStr(keys(0)))
    End If
End Function
'this is a function to remove the first element of an array
Public Function shift_ref(ByRef arr As Variant) As Variant
    Dim u As Long
    u = UBound(arr)
    Dim l As Long
    If u < 1 Then
        shift_ref = Array()
        Exit Function
    End If
    Dim v() As Variant
    For l = LBound(arr) To u - 1
        ReDim Preserve v(l)
        v(l) = arr(l + 1)
    Next
    shift_ref = v
End Function

'this is a function to push an element into an array
Public Function push_ref(ByVal val As Variant, ByRef arr As Variant) As Integer
    If IsArray(arr) Then
        ReDim Preserve arr(UBound(arr) + 1)
    Else
        ReDim arr(0)
    End If
    arr(UBound(arr)) = val
    push_ref = UBound(arr)
End Function
投稿者 kg88 時刻: 22:27 0 コメント

2012年2月4日土曜日

vbaのarrayのshiftメッソドを作ってみた

vbaのarrayのshiftメッソドを作ってみた
Function shift(ByVal arr As Variant) As Variant
    Dim u As Long
    u = UBound(arr)
    Dim l As Long
    If u < 1 Then
        shift = Array()
        Exit Function
    End If
    Dim v() As Variant
    For l = LBound(arr) To u - 1
        ReDim Preserve v(l)
        v(l) = arr(l + 1)
    Next
    shift = v
End Function

'検証
Sub test()
    Dim n As Variant
    n = Array("a", "b", "c")
    n = shift(n) 'n = array("b", "c")
End Sub
投稿者 kg88 時刻: 1:05 0 コメント

2012年2月2日木曜日

ディレクトリのサイズを調べるコマンド、便利

ラベル:
ディレクトリのサイズを調べるコマンド、便利

# du -hx --max-depth=1 path
155M ./fcft
127M ./sd
218M ./gred
13M ./sdefv
697M ./repos
536K ./sdsds
5.5M ./brre
411M ./gtte
4.0G .

こんな感じ
投稿者 kg88 時刻: 18:54 0 コメント

VBA再計算、再描画をオフにして、スピートを上げる

ラベル:
VBAで長いループを回す時、シートに書き出す必要がある時は、下のコードを入れると劇的早くなる場合があります。
'再計算を手動にする
Application.Calculation = xlCalculationManual
'画面描画を無効にする
Application.ScreenUpdating = False

'LOOPのブロック
for each ...

next

'画面描画を有効にする
Application.ScreenUpdating = True
'再計算を自動にする
Application.Calculation = xlCalculationAutomatic
'再計算を行う
Application.Calculate
ちなみに遅くなる原因は、ロープがシートに内容を書きこむことで、シートが再計算、再描画するからです。
マクロ「やってる感」を出すために再描画（Application.ScreenUpdating）だけを「True」にする場合もあります。
「お！すげぇ～～」と言われるためにね(๑¯ω¯๑)
投稿者 kg88 時刻: 17:05 0 コメント

vba変数宣言を強制化

ラベル:
VBAのソースコードの最先端にこの一行を書くと、変数のスペルミスが起こりにくくなる、おすすめ

Option Explicit

いつもこのspell忘れちゃうからメモしとこう...
投稿者 kg88 時刻: 11:32 0 コメント
登録: コメント (Atom)