Dim sht as WorkSheet
Set sht = ThisWorkbook.Worksheets("対象のシート")
sht.Copy
Dim sht as WorkSheet
Set sht = ThisWorkbook.Worksheets("対象のシート")
ThisWorkbook.Unprotect Password:=BKPWD
sht.Visible = True
sht.Copy
sht.Visible = False
ThisWorkbook.Protect Password:=BKPWD
'' 最後のブックを別名で保存 Workbooks(Workbooks.Count).SaveAs newFileNm, FileFormat:=xlNormal
Sub SaveAsOtherName
Dim newName As String
newName = _
Application.GetSaveAsFilename( _
InitialFileName:="デフォのファイル名" _
, FileFilter:="エクセルファイル(*.xls),*.xls" & _
",CSVファイル(*.csv),*.csv" _
, FilterIndex:=1 _
, Title:="保存先の指定" _
)
If newName = "FALSE" Then Exit Sub
If Dir(newName) <> "" Then
If MsgBox("同名のファイルが存在します。上書きしてもよろしいですか？", Title:=MSGBOX_TITLE, Buttons:=vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Dim sht As Worksheet: Set sht = ThisWorkbook.Worksheets("コピー対象シート名")
ThisWorkbook.Unprotect Password:=BKPWD
sht.Visible = True
sht.Copy
sht.Visible = False
ThisWorkbook.Protect Password:=BKPWD
Application.DisplayAlerts = False
'' 新ファイル名称の拡張子で保存形式を判定しています。
If CheckExtension("xls", newName) Then
Workbooks(Workbooks.Count).SaveAs newName, FileFormat:=xlNormal
Else
Workbooks(Workbooks.Count).SaveAs newName, FileFormat:=xlCSV
End If
ActiveWorkbook.Close
Application.DisplayAlerts = True
MsgBox "保存しました", Title:=MSGBOX_TITLE
End Sub
CREATE TABLE points ( point_id INT NOT NULL ,latlon GEOMETRY NOT NULL ,PRIMARY KEY (point_id) ,SPATIAL KEY (latlon) ) Engine=MyISAM;latlonカラムをSPATIAL INDEXとするため、MyISAMで使用します。
INSERT INTO points (
point_id
,latlon
) VALUES (
1
,GeomFromText('POINT(137.111 35.222)')
);
GeomFromTextはGeometry型に変換するMySQLの関数です。SELECT point_id ,X(latlon) as lon ,Y(latlon) as lat ,ASTEXT(latlon) as geomtext FROM points;Xは経度、Yは緯度、ASTEXTは文字表現を返す関数です。
SELECT
point_id
,X(latlon) as lon
,Y(latlon) as lat
FROM points
WHERE MBRContains(GeomFromText('LINESTRING(140.00 36.00, 139.20 35.55)'), latlon);
MBRContains、LINESTRING関数については、このサイトに詳しく載ってます。SELECT
point_id
,X(latlon) as lon
,Y(latlon) as lat
,GLength(GeomFromText(CONCAT('LineString(137.111 35.222,', X(latlon), ' ', Y(latlon),')'))) AS len
FROM points
ORDER BY len
LIMIT 0 , 1
GLength関数は、2点間の距離を取得します。
''' TEST
Private Sub test()
Dim sh As Worksheet
Dim db As Range, crt As Range, ext As Range
'' 結果のシート
Set sh = ThisWorkbook.Worksheets("抽出結果シート")
'' データ範囲指定
Set db = ThisWorkbook.Worksheets("データ").Range("A:X")
'' 抽出条件（タイトル含め条件の行数全部）
Set crt = sh.Range("A2:B3")
'' 抽出先（タイトル行のみ指定）
Set ext = sh.Range("D2:E3")
If doAdvancedFilter(db, crt, ext, True) Then
'’成功
End If
End Sub
''' AdvancedFilter実行
''' データレンジのシートがフィルタされてたら解除する
''' 抽出レンジのデータは末尾までクリアする
''' 検索レンジが1行の場合エラー
''' 検索レンジは2行以上指定すること
Public Function doAdvancedFilter(ByVal dbRange As Range, _
ByVal crtRange As Range, _
ByVal extRange As Range, _
ByVal unq As Boolean) As Boolean
On Error GoTo Err:
Dim sht As Worksheet
If crtRange.Rows.Count <= 1 Then
MsgBox "抽出条件が不正です"
Exit Function
End If
Set sht = dbRange.Parent
If sht.FilterMode Then sht.ShowAllData
'' 最大行数
Dim mxR As Long
Set sht = crtRange.Parent
mxR = sht.Rows.Count
'' extRangeクリア
Dim fCell As Range
Set fCell = extRange.Range("A1")
fCell.Offset(1, 0).Resize(fCell.Offset(1, 0).End(xlDown).Row - fCell.Row, extRange.Columns.Count).Clear
'' Filter実行
dbRange.AdvancedFilter xlFilterCopy, crtRange, extRange, unq
doAdvancedFilter = True
Exit Function
Err:
MsgBox Err.Description
End Function
var sample = function(){
alert="Hello!! World!!";
}
// ここにコードの内容
''-----------------------------------------------------------------------
'' 全プロジェクトファイルエクスポート（ブック・シートに付随するコード以外）
'' 事前にマクロのセキュリティ→VBAのオブジェクトモデルへのアクセスを許可する事（実行時エラーになります。）
''-----------------------------------------------------------------------
Private Sub Export_All()
Dim Path As String
Dim i As Integer
Const cls As String = "\Class\"
Const FRM As String = "\Form\"
Const MODL As String = "\Module\"
Const EXT_MODL As String = ".bas"
Const EXT_CLS As String = ".cls"
Const EXT_FRM As String = ".frm"
Path = ThisWorkbook.Path
'' エクスポートフォルダ
If Dir(Path & cls) = "" Then MkDir (Path & cls)
If Dir(Path & FRM) = "" Then MkDir (Path & FRM)
If Dir(Path & MODL) = "" Then MkDir (Path & MODL)
With ActiveWorkbook.VBProject
For i = 1 To .VBComponents.Count
Select Case .VBComponents(i).Type
Case 1 '' vbCompTypeModul
.VBComponents(i).Export Path & MODL & .VBComponents(i).Name & EXT_MODL
Case 2 '' vbCompTypeClassModul
.VBComponents(i).Export Path & cls & .VBComponents(i).Name & EXT_CLS
Case 3 '' vbCompTypeUserform
.VBComponents(i).Export Path & FRM & .VBComponents(i).Name & EXT_FRM
End Select
Next
End With
End Sub
''-----------------------------------------------
''--プロジェクトファイル洗い替え-----------------
''-----------------------------------------------
Private Sub Refresh()
Call Release_All
Call Import_All
End Sub
'' 全プロジェクトファイルリリース
Private Sub Release_All()
Dim i As Integer
Dim colComName As New Collection
With ThisWorkbook.VBProject
For i = 1 To .VBComponents.Count
If .VBComponents(i).Type = 1 Or .VBComponents(i).Type = 2 Or .VBComponents(i).Type = 3 Then
colComName.Add (.VBComponents(i).Name)
End If
Next
For i = 1 To colComName.Count
.VBComponents.Remove .VBComponents(colComName(i))
Next
End With
Set colComName = Nothing
End Sub
'' 全プロジェクトファイルインポート
Private Sub Import_All()
Dim Path As String
Dim i As Integer
Const cls As String = "\Class\"
Const FRM As String = "\Form\"
Const MODL As String = "\Module\"
Const EXT_MODL As String = ".bas"
Const EXT_CLS As String = ".cls"
Const EXT_FRM As String = ".frm"
Path = ThisWorkbook.Path
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fileList As Object
'' Cls
Set fileList = fso.GetFolder(Path & cls).Files
For Each file In fileList
ActiveWorkbook.VBProject.VBComponents.Import Path & cls & file.Name
Next
'' Form
Set fileList = fso.GetFolder(Path & FRM).Files
For Each file In fileList
If Right(file.Name, 4) = EXT_FRM Then
ActiveWorkbook.VBProject.VBComponents.Import Path & FRM & file.Name
End If
Next
'' Module
Set fileList = fso.GetFolder(Path & MODL).Files
For Each file In fileList
ActiveWorkbook.VBProject.VBComponents.Import Path & MODL & file.Name
Next
End Sub
'' グラフタイトル設定
.ChartObjects(1).Chart.ChartTitle.Text = GRAPHTITLE_ALL & " n=" & .Range(VALUE_N).Value
'' 画像ファイルのExport
.ChartObjects(1).Chart.Export ThisWorkbook.Path & GRAPHPICT_ALL
'' Visible Befor Export (for Excel2010)
ThisWorkbook.UnProtect password:="XXXXXXXXX"
.Visible = xlSheetVisible
'' 画像ファイルのExport
.ChartObjects(1).Chart.Export ThisWorkbook.Path & GRAPHPICT_ALL
.Visible = xlSheetHidden
ThisWorkbook.Protect password:="XXXXXXXXXX"
'' --
