月別アーカイブ: 2008年11月

Excel表をXML出力

投稿日時: 投稿者: 
Sub make_xml()
	Dim xdoc As New DOMDocument, xtree As IXMLDOMElement
	Dim PI As IXMLDOMProcessingInstruction
	Dim LOB As IXMLDOMElement
	Dim fld As IXMLDOMElement
	'xml header
	Set PI = xdoc.createProcessingInstruction(“xml", “version=’1.0′ encoding=’UTF-8′ standalone=’yes’")
	Call xdoc.appendChild(PI)
	'root tree
	Set xtree = xdoc.createElement(“all")
	xtree.Text = vbNewLine
	Call xdoc.appendChild(xtree)
	'横軸チェック
	x = 1
	Do While Cells(1, x) <> “": x = x + 1: Loop
	x = x – 1

	y = 2
	'縦ループ
	Do While Cells(y, 1) <> “"
		'親
		Set LOB = xdoc.createElement(“data")
		'横ループ
		For i = 1 To x
			'子1
			Set fld = xdoc.createElement(Cells(1, i))
			fld.Text = Cells(y, i)
			Call LOB.appendChild(fld)
			Call LOB.appendChild(xdoc.createTextNode(vbNewLine))
		Next
		'親書き出し
		Call xtree.appendChild(LOB)
		y = y + 1
	Loop
	'xml保存
	xdoc.Save (“c:\temp\swlist.xml")
	MsgBox “done"
End Sub

ピボット内の上位フィルター＆並び替え

投稿日時: 投稿者: 
Sub run()
	'引数：並べ替えのフィールド名、対象のシート名、Pivot実データの開始Y番号,TOP幾つまでを表示するか
	pivot_SORT_TOP "TITLE”, "Sheet4″, 5, 10
End Sub

'X軸は日付など、並び替え可能な項目であること
Sub pivot_SORT_TOP(CMname As String, pivot_sheet As String, Y As Long, TOP As Integer)

	Dim X As Long, CH As String

	Sheets(pivot_sheet).Select

	On Error Resume Next
	'縦の項目を一度、全部表示にする
	For i = 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
		ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = True
	Next
	
	'Pivotの末列の座標を探す
	X = 2
	Do While Cells(Y – 1, X) <> "”: X = X + 1: Loop
	X = X – 1
	
	'横列の昇順並び替え
	Cells(Y – 1, 2).Select
	Selection.Sort Order1:=xlAscending, Type:=xlSortLabels, OrderCustom:=1, _
		Orientation:=xlLeftToRight, SortMethod:=xlPinYin
	
	'並び替えたい列を選択
	Cells(Y, X).Select
	'Range(Chr(64 + X) & Y).Select
	
	'X,Y座標をR1C1形式に変換
	CH = "R” & Y & "C” & X
	'末列を降順でSORT
	Selection.Sort Key1:=CH, Order1:=xlDescending, Type:=xlSortValues, _
		OrderCustom:=1, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
	
	'表示項目がTOP指定より多い場合は、フィルター処理
	If ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count > TOP Then
	
		On Error Resume Next
		'TOP以降は非表示する
		For i = TOP + 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
			ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = False
		Next
	End If
	On Error GoTo 0
	
End Sub

タイマーにて自動呼出し処理

投稿日時: 投稿者: 
'タイマーを止める時に使う為、グローバル定義
Dim Next_timer As Date
Sub Timer_set()
	'次回のタイマー呼び出しは1分後
	Next_timer = Now + TimeValue("00:01:00")
	'1分後に呼び出す処理を登録
	Application.OnTime Next_timer, "Timer_go"

End Sub

Sub Timer_go()
	'1分後に呼ばれる処理を記述

End Sub

Sub Timer_stop()
	'登録済みのタイマーを止める処理（実行済みのタイマーなら意味なし）
	Application.OnTime Next_timer, Procedure:="Timer_go", Schedule:=False
	'注意：実行済みで呼ばれた場合エラーとなるため、on error resume nextなどが推奨

End Sub

Excelセル検索

投稿日時: 投稿者: 
Sub find_cell()

	Dim Found As Object, strID As String
	
	'sheet1内のA列を検索（完全一致）
	Set Found = Worksheets(“sheet1").Columns(“A:A").Find(strID, LookAt:=xlWhole)

	If Found Is Nothing Then
		MsgBox “「" & strID & “」は見つかりませんでした。"
	Else
		'見つかったセルの右隣(B=2列目)の値をゲット
		MsgBox Worksheets(“sheet1").Cells(Found.Row, 2)
		'その値を現在、セルがある場所にセット
		Cells(ActiveCell.Row, ActiveCell.Column) = Worksheets(“sheet1").Cells(Found.Row, 2)
	End If

End Sub