MW211 EXIT

devlog
ExcelVBA/シートまるごとコピー
2017年06月28日
既にある二つのシートのうち、一方を他方へまるごとコピーする方法は以下の通り。
┌──────────────────────────────────────┐
│With ThisWorkbook                                                           │
│    .Worksheets(入力シート名).AutoFilterMode = False                        │
│    .Worksheets(出力シート名).AutoFilterMode = False                        │
│    .Worksheets(入力シート名).Cells.Copy .Worksheets(出力シート名).Cells    │
│    Application.CutCopyMode = False                                         │
│End With                                                                    │
└──────────────────────────────────────┘
念のため事前にオートフィルタを解除しておく方がよい。
なお「Application.CutCopyMode = False」はクリップボードのクリアだ。
分類:ExcelVBA
ExcelVBA/複合キー重複チェック
2017年06月21日
単一キーの重複チェックは「COUNTIF()」などを駆使すれば一発だが
複合キーとなると中々めんどくさい。
一番簡単なのは、複合キーを文字列として結合し
単一キーにした上でチェックとなるのだが、どうも煩雑だ。

ということで、マクロで実装を試みた。
選択した範囲内で特定の列(変数で指定)の複合キー重複チェックを行う例。
┌──────────────────────────────────────┐
│'===========================================================================
│'  複合キー重複チェック                                                     
│'===========================================================================
│Public Sub 複合キー重複チェック()
│    Const X第一キー As Long = 1      '照合キー1の列(値は任意)
│    Const X第二キー As Long = 2      '照合キー2の列(値は任意)
│    Const X第三キー As Long = 3      '照合キー3の列(値は任意)
│    Const X出力     As Long = 0      '結果出力列(値は任意)
│    Dim y As Long, y検索 As Long
│    Dim is重複 As Boolean
│    Dim obj検索 As Range, 検索範囲 As Range
│    Application.ScreenUpdating = False
│    ActiveWorkbook.EnableAutoRecover = False
│    With Selection
│        Range(.Cells(1, X出力), .Cells(.Rows.count, X出力)).ClearContents
│        For y = 1 To .Rows.count - 1
│            If .Cells(y, X第一キー).Value <> "" Then
│                If .Rows(y).Row Mod 100 = 0 Then
│                    DoEvents
│                    Application.StatusBar = .Rows(y).Row
│                End If
│                If .Cells(y, X出力).Value = "" Then
│                    If WorksheetFunction.CountIf( _
│                        Range(.Cells(y + 1, X第一キー), .Cells(.Rows.count, X第一キー)), _
│                        .Cells(y, X第一キー).Value _
│                    ) > 0 Then
│                        is重複 = False
│                        Set 検索範囲 = Range(.Cells(y, X第一キー), .Cells(.Rows.count, X第一キー))
│                        Set obj検索 = 検索範囲.Find( _
│                            What:=.Cells(y, X第一キー).Value, _
│                            After:=.Cells(y, X第一キー), _
│                            LookIn:=xlValues, _
│                            LookAt:=xlWhole, _
│                            SearchOrder:=xlByRows, _
│                            SearchDirection:=xlNext, _
│                            MatchCase:=True, _
│                            MatchByte:=True _
│                        )
│                        Do Until obj検索.Address = .Cells(y, X第一キー).Address
│                            y検索 = obj検索.Row - .Rows(1).Row + 1
│                            If .Cells(y検索, X第二キー).Value = .Cells(y, X第二キー).Value _
│                            And .Cells(y検索, X第三キー).Value = .Cells(y, X第三キー).Value Then
│                                .Cells(y検索, X出力).Value = "重"
│                                is重複 = True
│                            End If
│                            Set obj検索 = 検索範囲.FindNext(obj検索)
│                        Loop
│                        If is重複 Then
│                            .Cells(y, X出力).Value = "重"
│                        End If
│                    End If
│                End If
│            End If
│        Next y
│    End With
│    Application.StatusBar = False
│    ActiveWorkbook.EnableAutoRecover = True
│    Application.ScreenUpdating = True
│End Sub
└──────────────────────────────────────┘
分類:ExcelVBA
ExcelVBA/正規表現
2017年06月15日
ExcelVBAで正規表現を行うには「VBScript.RegExp」オブジェクトを利用する。
┌──────────────────────────────────────┐
│'===========================================================================│
│'  正規表現のテスト(括弧内の数値を取得)                                     │
│'===========================================================================│
│Public Sub 正規表現のテスト()                                               │
│    Dim REG As Object                                                       │
│    Set REG = CreateObject("VBScript.RegExp")                               │
│    REG.Pattern = "^.*\((\d+)\).*$"                                         │
│    Dim theCell As Range                                                    │
│    For Each theCell In Selection                                           │
│        If REG.Test(theCell.Value) Then                                     │
│            theCell.Value = REG.Replace(theCell.Value, "$1")                │
│        End If                                                              │
│    Next theCell                                                            │
│End Sub                                                                     │
│'===========================================================================│
└──────────────────────────────────────┘
「.TEST()」メソッドは、一致するの判定に、
「.Replace()」メソッドは、置換に、それぞれ利用する。
正規表現のパターンは「.Pattern」に代入して使用する。
分類:ExcelVBA
ExcelVBA/セルの範囲が広いと思ったら
2017年03月04日
┌──────────────────────────────────────┐
│Public Sub セルの範囲が広いと思ったら()                                     │
│    MsgBox ThisWorkbook.ActiveSheet.UsedRange.Row   ' ダミー処理            │
│End Sub                                                                     │
└──────────────────────────────────────┘
分類:ExcelVBA
ExcelVBA/MSSQL小数のプレースホルダ
2017年01月17日
┌──────────────────────────────────────┐
│CREATE PROCEDURE [dbo].[PROCEDURE_小数]                                     │
│    @引数小数               [decimal](8, 2)                                 │
└──────────────────────────────────────┘
MSSQLのストアドプロシージャの引数をdecimal型の小数で定義した場合
ExcelVBAのプレースホルダ的には、以下のような形式で値を指定してあげる。
┌──────────────────────────────────────┐
│Dim SQLコマンド As New ADODB.Command                                        │
│With SQLコマンド                                                            │
│    .ActiveConnection = mデータベース                                       │
│    .CommandType = adCmdStoredProc                                          │
│    .CommandText = "PROCEDURE_小数"                                         │
│    .NamedParameters = True                                                 │
│    .Parameters.Append .CreateParameter("@引数小数", adDecimal, adParamInput)
│    With .Parameters("@引数小数")                                           │
│        .Precision = 8                                                      │
│        .NumericScale = 2                                                   │
│    End With                                                                │
│    .Execute                                                                │
└──────────────────────────────────────┘
分類:ExcelVBA、MSSQL
ExcelVBA/接続時間延長
2015年08月26日
ExcelVBAでADODBを使ってMSSQLに問い合わせをしたが
SQLの処理が長すぎてタイムアウトエラーとなってしまう場合
以下のようにタイムアウト時間を延長することができる。
┌──────────────────────────────────────┐
│Dim テーブル As New ADODB.Recordset                                         │
│Dim SQLコマンド As New ADODB.Command                                        │
│With SQLコマンド                                                            │
│    .CommandTimeout = 180   ' ←★接続時間延長(30秒→180秒)                 │
│    .ActiveConnection = (データベース接続情報)                              │
│    .CommandText = (SQL文)                                                  │
│End With                                                                    │
│テーブル.Open SQLコマンド                                                   │
└──────────────────────────────────────┘
但し、基本的に処理が長すぎるSQL文を見直すべきで(インデックスの追加など)
上記手段を行うのは最後の最後もしくは特例的に限定すべきである。
分類:ExcelVBA、MSSQL
ExcelVBA/DoEventsとは
2015年08月14日
正式には「Application.DoEvents」メソッドだが、
省略形で「DoEvents」と記述されることが多い。

Unix系はマルチタスクOSだが、Windows系は疑似マルチタスクOSである。

つまり直列的に処理が行われるので、Excelで重い処理を行うと
一部の他処理が止まってしまう(画面が真っ白になったりする)。

そのような場合、処理と処理の間に「DoEvents」を挟むことにより、
そのタイミングでOSへ処理を一旦返上し、
溜まっていた処理を吐き出す(実行する)ことができるようになる。

当然ながら、再びはOSより処理は戻ってくるので、続きが行われる。
分類:ExcelVBA
ExcelVBA/保存先指定ダイアログ
2015年08月12日
保存先をダイアログで指定するようにする方法。
┌──────────────────────────────────────┐
│Dim 保存先ファイル名 As String                                              │
│ChDir ActiveWorkbook.Path   ' 本ファイルのフォルダを既定とする              │
│保存先ファイル名 = Application.GetSaveAsFilename( _                         │
│    InitialFileName:="既定ファイル.txt", _                                  │
│    FileFilter:="テキストファイル,*.txt,すべてのファイル,*.*" _             │
│)                                                                           │
│If 保存先ファイル名 = "False" Then                                          │
│    MsgBox "ファイルを指定し直してください", vbInformation, "処理終了"      │
│    Exit Sub                                                                │
│End If                                                                      │
│Msgbox 保存先ファイル名  ' フルパスが取得できるので保存先に利用             │
└──────────────────────────────────────┘
「.GetSaveAsFilename()」メソッドを使う。
既定ファイル名は「InitialFileName」パラメータで指定する。
既定フォルダは、直前に「ChDir」でディレクトリ移動することにより指定となる。
分類:ExcelVBA
ExcelVBA/翻訳
2015年08月11日
Google翻訳を利用した英和・和英の一括翻訳マクロ。
セル選択(複数可)して実行すると、右隣に翻訳結果が出力される。
┌──────────────────────────────────────┐
│Public Sub Google翻訳英和()                                                 │
│    Dim i As Long                                                           │
│    Dim theCell As Range                                                    │
│    Dim objIE As Object                                                     │
│    For Each theCell In Selection                                           │
│        If theCell.Value <> "" Then                                         │
│            Application.Wait Now + TimeValue("00:00:01")  ' スリープ約1秒   │
│            Set objIE = CreateObject("InternetExplorer.Application")        │
│            With objIE                                                      │
│                .Navigate "https://translate.google.co.jp/#en/ja/" _        │
│                        & theCell.Value                                     │
│                Do While .Busy Or .ReadyState <> 4                          │
│                    DoEvents                                                │
│                Loop                                                        │
│                With .Document.getElementById("result_box")                 │
│                    For i = 1 To 10000  ' リトライ                          │
│                        If .innerText <> "" Then                            │
│                            Exit For                                        │
│                        End If                                              │
│                        DoEvents                                            │
│                    Next i                                                  │
│                    theCell.Offset(, 1).Value = .innerText                  │
│                End With                                                    │
│                .Quit                                                       │
│            End With                                                        │
│        End If                                                              │
│    Next theCell                                                            │
│    MsgBox "完了"                                                           │
│End Sub                                                                     │
├──────────────────────────────────────┤
│Public Sub Google翻訳和英()                                                 │
│    Dim i As Long                                                           │
│    Dim theCell As Range                                                    │
│    Dim objIE As Object                                                     │
│    For Each theCell In Selection                                           │
│        If theCell.Value <> "" Then                                         │
│            Application.Wait Now + TimeValue("00:00:01")  ' スリープ約1秒   │
│            Set objIE = CreateObject("InternetExplorer.Application")        │
│            With objIE                                                      │
│                .Navigate "https://translate.google.co.jp/#ja/en/" _        │
│                        & theCell.Value                                     │
│                Do While .Busy Or .ReadyState <> 4                          │
│                    DoEvents                                                │
│                Loop                                                        │
│                With .Document.getElementById("result_box")                 │
│                    For i = 1 To 10000  ' リトライ                          │
│                        If .innerText <> "" Then                            │
│                            Exit For                                        │
│                        End If                                              │
│                        DoEvents                                            │
│                    Next i                                                  │
│                    theCell.Offset(, 1).Value = .innerText                  │
│                End With                                                    │
│                .Quit                                                       │
│            End With                                                        │
│        End If                                                              │
│    Next theCell                                                            │
│    MsgBox "完了"                                                           │
│End Sub                                                                     │
└──────────────────────────────────────┘
「.Busy Or .ReadyState <> 4」の条件でIEの読込完了を待つのだが、
ID指定で要素を読み込むためにはさらに若干タイムラグがある模様。

それが未だだと空欄取得となってしまうので、リトライを用意した。

なお、クローラみたいなものなので1秒間をあけて実行するようにした。
分類:ExcelVBA
ExcelVBA/UTF-8出力
2015年08月10日
ExcelVBAでは、通常「Shift-JIS」で出力されるが、これを「UTF-8」にしたい場合。

「ADODB.Stream」を使用する。
まず、参照設定にて
「Microsoft ActiveX Data Object6.1 Library」にチェックを入れること。


そしてサンプルソースとしては以下のような感じに処理を行えばよい。
┌──────────────────────────────────────┐
│Public Sub UTF8出力()                                                       │
│    Dim 出力先 As New ADODB.Stream                                          │
│    With 出力先                                                             │
│        .Type = adTypeText                                                  │
│        .Charset = "UTF-8"                                                  │
│        .LineSeparator = adCRLF                                             │
│        .Open                                                               │
│    End With                                                                │
│    出力先.WriteText Cells(1, 1).Value                                      │
│    出力先.SaveToFile ActiveWorkbook.Path & "\output.txt", _                │
│                      adSaveCreateOverWrite                                 │
│    出力先.Close                                                            │
│    MsgBox "完了"                                                           │
│End Sub                                                                     │
└──────────────────────────────────────┘
分類:ExcelVBA
前へ 1 … 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 … 27 次へ