指定したURLのHTMLを頭から256字抽出する

Public Sub 実行()
    Dim objIE As InternetExplorer
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True '見えるようにする
    objIE.navigate "http://www.yahoo.co.jp/" 'URLを適宜入力する
   
    'IEを起動する
    Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
        DoEvents
    Loop
   
    'FunctionでgetHTMLStringを呼び出し、HTMLの文字列を取得する
    Dim HTMLString As String
    HTMLString = HTML取得(objIE)
   
    '書き込み開始
    ThisWorkbook.Activate
    With Range("A1")
        .Clear
        .Value = Left(HTMLString, 256)
    End With
End Sub

Private Function HTML取得(container As Object, Optional depth As Long = 0) As String
    Dim ErrorInfo As String
    Dim htdoc As HTMLDocument
   
    '↓↓↓HTML文書取得時のエラーを無視する↓↓↓
    On Error Resume Next
    Set htdoc = container.document
   
    If Err.Number <> 0 Then
        'エラー情報を保持する
        ErrorInfo = Trim(str(Err.Number)) & ":" & Err.Description
    End If
   
    On Error GoTo 0
    '↑↑↑HTML文書取得時のエラーを無視する↑↑↑
   
    Dim ret As String
    ret = "-------------" & vbCrLf  '区切り値作成
    ret = ret & "[" & Trim(str(depth)) & "階層]" & vbCrLf
    If Not htdoc Is Nothing Then
        ret = ret & htdoc.Title & " | " & htdoc.Location & " (" & container.Name & ")" & vbCrLf
        ret = ret & "-------------" & vbCrLf
        ret = ret & htdoc.getElementsByTagName("HTML")(0).outerHTML & vbCrLf  'HTMLソース全体を取得
   
        'フレームの数だけ繰り返す
        Dim i As Integer
        For i = 0 To htdoc.frames.Length - 1
            ret = ret & HTML取得(htdoc.frames(i), depth + 1)
        Next
    Else
        ret = ret & "-------------" & vbCrLf
        ret = ret & ErrorInfo
    End If
   
    HTML取得 = ret
End Function

シート名 および セル範囲 を取得する

下記モジュールをダイアログのOKボタンなどに登録して、
範囲選択後に、
シート名　および　セル範囲　を debug.print で出力する。

-------------------------------------------

Sub シート名とセル範囲()
　'ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽの[OK]ボタンに登録しています

　Dim myAns As String
　Dim i As Long

　Dim myShe As String '別のシート名を格納する

　Dim myFlag1 As Boolean '別のシートを選択したか
　Dim myFlag2 As Boolean '範囲選択か

　Dim Val1 As String '範囲選択の始点
　Dim Val2 As String '範囲選択の終点

　'初期値設定
　myFlag1 = False
　myFlag = False

　'①範囲選択を分解する
　myAns = Sheets("Dialog2").EditBoxes(1).Text

　For i = 1 To Len(myAns)
　　'-1：アクティブシートか？別のシートを選択したか？
　　　If Mid(myAns, i, 1) = "!" Then '
　　　'別のシートを選択した場合は "!"がある
　　　　myFlag1 = True
　　　　myShe = Left(myAns, i - 1)
　　　End If

　　'-2：範囲選択か？単一セルか？
　　If Mid(myAns, i, 1) = ":" Then
　　'範囲選択の場合→":"がある
　　　myFlag2 = True 'フラグをtrueにする
　　　Exit For 'ループから抜ける
　　　'変数iは":"までの字数を意味する
　　End If
　Next i

　'②値を取得するし、イミディエイトウィンドに出力します
　If myFlag1 = True And myFlag2 = True Then
　　'-1：別のシートを選択し、範囲選択している
　　Val1 = Mid(myAns, Len(myShe) + 2, i - (Len(myShe) + 2))
　　Val2 = Right(myAns, Len(myAns) - i)
　　Debug.Print myShe & "シート　の" & Val1 & " ～ " & Val2 & "　の範囲を取得しました"

　ElseIf myFlag1 = True And myFlag2 = False Then
　　'-2：別のシートを選択し、単一のセルを選択している
　　Val1 = Right(myAns, Len(myAns) - Len(myShe))
　　Debug.Print myShe & "シート　の" & Val1 & "　を取得しました"

　ElseIf myFlag1 = False And myFlag2 = True Then
　'-3：アクティブシートを選択し、範囲選択している
　　Val1 = Left(myAns, i - 1)
　　Val2 = Right(myAns, Len(myAns) - i)
　　Debug.Print Val1 & " ～ " & Val2 & "　の範囲を取得しました"

　ElseIf myFlag1 = False And myFlag2 = False Then
　'-4：アクティブシートを選択し、単一のセルを選択している
　　Val1 = Left(myAns, Len(myAns))
　　Debug.Print Val1 & "　を取得しました"

　End If

End Sub

ダイアログ呼び出し例

Sub ダイアログ呼び出し()
　With Sheets("Dialog2")　’ダイアログの名前（シートの並びに記されています）
　　.Show 'ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽを表示
　　.EditBoxes(1).Text = "" 'テキストボックスの初期値をクリアする
　End With
End Sub

.show　→　開く
.Text 　→　値を取得する

ボタンでセルを参照する

セルの範囲指定をｳｨｻﾞｰﾄﾞ形式で取得するにあたって、

Dialogsコレクションを用いる方法を記す。



1）エクセルの下段にある[ツールボックス]ツールバーの余白を右クリックし、

[挿入]を選択すると下図の画面が表示される。

[MS Excel5.0　ダイアログ]を選択する。

2）下図のような画面になる。

リボンの場合は[開発]などから、

ユーザーフォームを作成する要領で、

オブジェクトを作成して適宜マクロを登録する。

3）テキストボックスを右クリックして[コントロールの書式設定]を選択する。


※Dialogsコレクションの名前はシート名などと同じく、
下図の部分にも記されている。
コピペなどで適宜利用のこと。

ピボットテーブルを作成する

’読込シートA1～M最下行までのデータを元に
’分析結果シートのD7セルへ
’ピボットテーブル（テーブル名"結果_P"）を作成する。

　Sheets("分析結果").Select
　ActiveWindow.FreezePanes = False

'既存ピボット削除
　Columns("D:BB").Delete Shift:=xlToLeft

　Sheets("読込").Select
　Range("A1").Select

’①ピボットテーブル作成　項目は↓適宜変更すると良い
　ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
　"読込!A1:M" & Cells(Rows.Count, "M").End(xlUp).Row & "") _
　.CreatePivotTable TableDestination:=Worksheets("分析結果").Range("D7") _
　, TableName:="結果_P"


’②ピボットテーブルの設定
　　’ピボットフィールドに　請求先名　を指定する
　With ActiveSheet.PivotTables("結果_P").PivotFields("請求先名")
　　.Orientation = xlRowField　'行の指定
　　.Position = 1　’一行目
　End With

　’ピボットフィールドに　出荷先名　を指定する
　With ActiveSheet.PivotTables("結果_P").PivotFields("出荷先名")
　　.Orientation = xlRowField　'行の指定
　　.Position = 2　’二行目
　End With

’ピボットフィールドに　日　を指定する
　With ActiveSheet.PivotTables("結果_P").PivotFields("日")
　　.Orientation = xlColumnField　 '列の指定
　　.Position = 1　’一行目
　End With

’集計データを指定する　⇒ピボットフィールド「ケース数量」の個数を集計する
　ActiveSheet.PivotTables("結果_P").AddDataField ActiveSheet.PivotTables( _
　"結果_P").PivotFields("ケース数量"), "データの個数 / ケース数量", xlCount

TXTからデータを読み込む

sub test()



 Dim buf As String, n As Long,myBuf as variant , i as Long
 Dim myTxtFile as string



　myTxtFile = "xxxxx.txt" '読み込むテキストファイル名


 ’テキストファイルはｴｸｾﾙブックと同じフォルダにあると仮定する





　Open ThisWorkbook.Path & "\" & myTxtFile For Input As #1　
　Do Until EOF(1)
　　Line Input #1, buf


　　myBuf = Split(buf,chr(9)) 'chr(9)はタブスペースを表す


　　For i = 1 to Ubound(myBuf) '1～myBufの最大配列数まで繰り返す
　　　Cells(n, i).value = myBuf(i) '書き込み開始
　　Next i


　Loop


　Close #1





end sub

SQLを使ってデータ操作をする

Sub test()
'VBAエディタ - ツール - 参照設定 - Microsoft ActiveX Data Objects 2.8 Library　要チェック



'画面の更新を止める
Application.ScreenUpdating = False


'↓↓↓ADO↓↓↓
Dim myCn As New ADODB.Connection
Dim myRs As New ADODB.Recordset
Dim myFile As Variant

'myFile に読み込むデータの保存先を設定する（適宜変更必要）
'（今回は設定シートのA1セルにアドレスがあるとする）
myFile = ThisWorkbook.Sheets("設定").Cells(1, 1).Value

With myCn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=NO" 'HDRがNOなら、一行目からデータが始まっていると判断する
.Properties("Data Source") = myFile
.Open
End With
'※excel2007以降はMicrosoft.Ace.OLEDB.12.0を使用します※

'SQL文（適宜変更必要）
'[　$]内はシート名を設定する
Set myRs = myCn.Execute("SELECT * FROM [Sheet1$]")

'データシートの...
With ThisWorkbook.Sheets("データ")
.Cells.Clear '以前抽出したデータを削除する
.Cells(2, 1).CopyFromRecordset myRs 'A2セルにSQLで抽出したデータを取り込む
'フィールドの項目作成
　 For x = 0 To myColMux
　　 .Cells(myRow, x + 1).Value = rs(x).Name
　 Next
End With

　 rs.Close
　 cn.Close
End Sub

VBA高速化

・シートやウィンドウが切り替わるのを見せない

　Application.ScreenUpdating = False　

　（実行後は特にTrueに変更せずとも、自動的にTrueになるが、万一の事を考えて

　Application.ScreenUpdating = False　

　と明記した方が良い）




・別のイベントプロシージャを停止する

　Application.EnableEvents = False

　↓実行後は次のコードを加える

　Application.EnableEvents = True




・手動計算に切り替えて随時シート内の関数を実行しない

　Application.Calculation = xlCalculationManual

　↓実行後は次のコードを加える

　Application .Calculation = xlCalculationAutomatic




例1）処理の実行時

with Application
　.ScreenUpdating = False　
　.EnableEvents = False
　.Calculation = xlCalculationManual
End With



例2）処理の終了時

with Application
　.ScreenUpdating = True
 .EnableEvents = True
 .Calculation = xlCalculationAutomatic
End With

ユーザーフォーム

≪値操作≫
・ラベル.caption
・テキストボックス.value
・コンボボックス.value



≪リストボックスの項目作成≫
例）リストボックスにトランプの絵柄を入れる。

With Me .リストボックス
　.AddItem "ハート"
　.AddItem "ダイヤ"
　.AddItem "クローバー"
　.AddItem "スペード"
End With



≪オブジェクトと変数を組み合わせて値を読み込む≫
例）シートA列の値を一行目から読み込み、フォームのラベル（L_変数）へ表示させる。

dim i as long
i = 1
do while sheets(1).cells(i,"A").value <> ""
Me.Controls("L_" & i).Value = sheets(1).cells(i,"A").value
i = i + 1
loop

デスクトップへ保存

・"ｘｘｘｘｘ.xls" は保存する名前

Sub test()
　Dim Path As String, 　WSH As Variant
　Set WSH = CreateObject("Wscript.Shell")
　Path = WSH.SpecialFolders("Desktop") & "\"
　ActiveWorkbook.SaveAs Path & "ｘｘｘｘｘ.xls"
　Set WSH = Nothing
End Sub