皆様おはこんばんちわ。
セル(Ex.B2,B3,B4)をダブルクリックする度に、そのセル内にオートシェイプを描画／削除したいのです。
描画は下記（で良いのかですが）で出来たのですが、削除がどうしてもわかりません。
-------------------------------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("B2:B4")) Is Nothing Then Exit Sub
With ActiveCell
With ActiveSheet.Shapes.AddShape _
(msoShapeOval, .Left, .Top, .Width, .Height)
.Fill.Visible = msoFalse
.Line.Weight = 1.75
.Line.ForeColor.SchemeColor = 0
End With
End With
End Sub
-------------------------------------------------------------------------
既に図形があるセルをダブルクリックで削除するにはどの様な方法があるのでしょうか。
バージョンはExcel2007です。
皆様よろしくご教示ください。
皆様おはこんばんちわ。
セル(Ex.B2,B3,B4)をダブルクリックする度に、そのセル内にオートシェイプを描画／削除したいのです。
描画は下記（で良いのかですが）で出来たのですが、削除がどうしてもわかりません。
-------------------------------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("B2:B4")) Is Nothing Then Exit Sub
With ActiveCell
With ActiveSheet.Shapes.AddShape _
(msoShapeOval, .Left, .Top, .Width, .Height)
.Fill.Visible = msoFalse
.Line.Weight = 1.75
.Line.ForeColor.SchemeColor = 0
End With
End With
End Sub
-------------------------------------------------------------------------
既に図形があるセルをダブルクリックで削除するにはどの様な方法があるのでしょうか。
バージョンはExcel2007です。
皆様よろしくご教示ください。
セルの変更時、列によって行の内容を変更するプログラムを組んだのですが、
エラーが起きてうまくいきません。
使用しているExcelは2007です。
ファイルを参照するあたりが全然わかってないのでそのあたりがあやしいです。
実行時エラー '91':
オブジェクト変数または With ブロック変数が設定されていません。
→ hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '係数表をコピー
↓デバッグ押すと
実行時エラー '-2147417848 (80010108)':
'Value' メソッドは失敗しました: 'Range'オブジェクト
→ Call all_feeCulc_change2(target.Parent.Name, target.row)
番号をメモし忘れました。91かこれが表示されます。どちらが出るかわかりません。
'Range' メソッドは失敗しました:'_Worksheet' オブジェクト
→endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得
何回かリトライして開いたり閉じたりを繰り返したら↓のようなダイアログも出ました。
マクロでスタック領域が不足しています
また、ダイアログで終了を押したらセルを正しく選択できなくなりました。
デバッグを押したら、停止ボタンを押すと応答なしになった後、Excelが終了し再起動しました。
そして、どちらを選択した場合でも、メニューや閉じるボタンを押してもExcelが終了できず、
タスクマネージャからプロセスを終了させるしかなかったです。
その時CPU使用率が50%を超えてたりと異常事態になっております。
###標準モジュール###
Sub all_feeCulc_change2(ByVal sheetName As String, ByVal row As Integer)
If sheetName <> "" Then
Dim customer As String
customer = Worksheets(sheetName).Cells(row, 3)
On Error Resume Next
Dim book1 As Workbook '別ファイルのオープン（触らない）
Workbooks.Open Filename:="hogehoge.xlsm" '別ファイルのオープン（触らない）
Set book1 = Workbooks("hogehoge.xlsm") '別ファイルのオープン（触らない）
On Error GoTo 0
Dim endrow As Integer '最終行番号
endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得
Dim hoge As Variant
hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '早見表から係数表をコピー
With Worksheets(sheetName)
...
###ThisWorkbook###
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
If target.Count = 1 Then
Dim column As Integer
Dim row As Integer
column = target.column
row = target.row
If row >= 3 Then
If ((column - 3) Mod 5) = 2 And column > 3 Then '更新セルがメーターだったら
Call usageCulc_change(target.Parent.Name, target.column, target.row)
Call all_feeCulc_change(target.Parent.Name, target.column - 1, target.row)
Call chenge_tax_change(target.Parent.Name, target.column + 1, target.row)
ElseIf column = 3 Then
target.Value = format(target.Value, "000") '誤入力防止
Call all_feeCulc_change2(target.Parent.Name, target.row)
Call chenge_tax_change2(target.Parent.Name, target.row)
End If
End If
End If
End Sub
Private Sub Workbook_Open()
'*****すべてのシート名を取得*****'
Dim ws As Worksheet
Dim sheetName() As String
ReDim sheetName(3)
Dim cnt As Integer
cnt = 0
For Each ws In Worksheets
If cnt > 3 And (cnt Mod 4) = 0 Then
ReDim Preserve sheetName(UBound(sheetName) + 4)
End If
sheetName(cnt) = ws.Name
cnt = cnt + 1
Next
'*****取得終了*****'
Dim endrow As Integer
Dim line As Variant
For Each line In sheetName
If line <> "000" And line <> "" Then
With Worksheets(line)
endrow = .Cells(Rows.Count, 3).End(xlUp).row
Dim i As Integer
Dim j As Integer
For i = 0 To endrow
For j = 0 To 11
.Cells(3 + i, 4 + j * 5).NumberFormatLocal = "0.0"
.Cells(3 + i, 5 + j * 5).NumberFormatLocal = "0.0"
.Cells(3 + i, 6 + j * 5).NumberFormatLocal = "#,##0"
.Cells(3 + i, 7 + j * 5).NumberFormatLocal = "#,##0"
.Cells(3 + i, 8 + j * 5).NumberFormatLocal = "#,##0"
Next j
Next i
End With
End If
Next
End Sub
セルの変更時、列によって行の内容を変更するプログラムを組んだのですが、
エラーが起きてうまくいきません。
使用しているExcelは2007です。
ファイルを参照するあたりが全然わかってないのでそのあたりがあやしいです。
実行時エラー '91':
オブジェクト変数または With ブロック変数が設定されていません。
→ hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '係数表をコピー
↓デバッグ押すと
実行時エラー '-2147417848 (80010108)':
'Value' メソッドは失敗しました: 'Range'オブジェクト
→ Call all_feeCulc_change2(target.Parent.Name, target.row)
番号をメモし忘れました。91かこれが表示されます。どちらが出るかわかりません。
'Range' メソッドは失敗しました:'_Worksheet' オブジェクト
→endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得
何回かリトライして開いたり閉じたりを繰り返したら↓のようなダイアログも出ました。
マクロでスタック領域が不足しています
また、ダイアログで終了を押したらセルを正しく選択できなくなりました。
デバッグを押したら、停止ボタンを押すと応答なしになった後、Excelが終了し再起動しました。
そして、どちらを選択した場合でも、メニューや閉じるボタンを押してもExcelが終了できず、
タスクマネージャからプロセスを終了させるしかなかったです。
その時CPU使用率が50%を超えてたりと異常事態になっております。
###標準モジュール###
Sub all_feeCulc_change2(ByVal sheetName As String, ByVal row As Integer)
If sheetName <> "" Then
Dim customer As String
customer = Worksheets(sheetName).Cells(row, 3)
On Error Resume Next
Dim book1 As Workbook '別ファイルのオープン（触らない）
Workbooks.Open Filename:="hogehoge.xlsm" '別ファイルのオープン（触らない）
Set book1 = Workbooks("hogehoge.xlsm") '別ファイルのオープン（触らない）
On Error GoTo 0
Dim endrow As Integer '最終行番号
endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得
Dim hoge As Variant
hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '早見表から係数表をコピー
With Worksheets(sheetName)
...
###ThisWorkbook###
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
If target.Count = 1 Then
Dim column As Integer
Dim row As Integer
column = target.column
row = target.row
If row >= 3 Then
If ((column - 3) Mod 5) = 2 And column > 3 Then '更新セルがメーターだったら
Call usageCulc_change(target.Parent.Name, target.column, target.row)
Call all_feeCulc_change(target.Parent.Name, target.column - 1, target.row)
Call chenge_tax_change(target.Parent.Name, target.column + 1, target.row)
ElseIf column = 3 Then
target.Value = format(target.Value, "000") '誤入力防止
Call all_feeCulc_change2(target.Parent.Name, target.row)
Call chenge_tax_change2(target.Parent.Name, target.row)
End If
End If
End If
End Sub
Private Sub Workbook_Open()
'*****すべてのシート名を取得*****'
Dim ws As Worksheet
Dim sheetName() As String
ReDim sheetName(3)
Dim cnt As Integer
cnt = 0
For Each ws In Worksheets
If cnt > 3 And (cnt Mod 4) = 0 Then
ReDim Preserve sheetName(UBound(sheetName) + 4)
End If
sheetName(cnt) = ws.Name
cnt = cnt + 1
Next
'*****取得終了*****'
Dim endrow As Integer
Dim line As Variant
For Each line In sheetName
If line <> "000" And line <> "" Then
With Worksheets(line)
endrow = .Cells(Rows.Count, 3).End(xlUp).row
Dim i As Integer
Dim j As Integer
For i = 0 To endrow
For j = 0 To 11
.Cells(3 + i, 4 + j * 5).NumberFormatLocal = "0.0"
.Cells(3 + i, 5 + j * 5).NumberFormatLocal = "0.0"
.Cells(3 + i, 6 + j * 5).NumberFormatLocal = "#,##0"
.Cells(3 + i, 7 + j * 5).NumberFormatLocal = "#,##0"
.Cells(3 + i, 8 + j * 5).NumberFormatLocal = "#,##0"
Next j
Next i
End With
End If
Next
End Sub
Excel、ACCESSの2003を使用しています。
Excelで、指定した期間の情報をmdb上よりExcel側に出力する処理を考えています。
mdbファイルの接続先がテーブルならうまく処理できます。
しかし今回の接続先がクエリの為か、処理を動かしてもエラーは出ないのですが値が無い扱いになっています。
mdbのテーブルにはリンクテーブルで2つのテーブルがあります。
クエリ側で2つのテーブルをリレーションしており、クエリで表示している内容をExcel側に返したいのです。
下記の処理はクエリに接続をしていないのでしょうか？
Option Explicit
Const cnsADO_CONNECT1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Dim dbCon As New ADODB.Connection
Dim dbRes As New ADODB.Recordset
Dim dbCol As ADODB.Field
Dim strSQL As String, strStartDate As String, strEndDate As String
Dim lngGyo As Long, lngCol As Long
Dim strRootPath As String, strFileName As String, strPath As String
Dim intField As Integer, i As Integer, j As Integer
Public Sub ACCESS接続()
strRootPath = "\\11.111.11.1\00_テストフォルダ\" 'IPアドレスとフォルダ選択
strPath = "00_環境設定\01_テスト用\" 'パス先
strFileName "テスト.mdb" 'mdb名
dbCon.Open cnsADO_CONNECT1 & strRootPath & strPath & strFileName 'mdb接続
strStartDate = "#09/01/2014# AND "
strEndDate = "#09/23/2014#)"
'''''SQLビューの内容をそのまま'''''
strSQL = "SELECT テーブルA.年月日, テーブルA.実績No., テーブルB.依頼数, テーブルA.略号, テーブルA.作成No., テーブルA.数値No., テーブルA.名称, テーブルA.ＣＤ, テーブルA.長さ, テーブルA.場所, テーブルA.フラグ, "
strSQL = strSQL & "Format([年月日],""yyyy/mm/dd"") AS 作成年月日"
strSQL = strSQL & vbNewLine & "FROM テーブルB INNER JOIN テーブルA ON テーブルB.依頼No.=テーブルA.実績No."
strSQL = strSQL & vbNewLine & "WHERE (((テーブルA.年月日) Between "
strSQL = strSQL & strStartDate
strSQL = strSQL & strEndDate
strSQL = strSQL & " AND ((テーブルA.ＣＤ) Not Like ""%KN%"") AND ((テーブルA.場所) Like ""*IO*"") AND ((テーブルA.フラグ) Is Null))"
strSQL = strSQL & vbNewLine & "ORDER BY テーブルA.年月日;"
'''''SQLビューの内容をそのまま'''''
dbRes.Open strZisseki_SQL, dbCon, adOpenKeyset, adLockReadOnly 'レコードセット
intField = dbRes.Fields.Count
lngGyo = 1
dbRes.MoveFirst
Do Until dbRes.EOF
lngGyo = lngGyo + 1
lngCol = 0
For Each dbCol In dbRes.Fields
lngCol = lngCol + 1
Cells(lngGyo, lngCol) = dbCol.Value
Next dbCol
dbRes.MoveNext
Loop
dbRes.Close: Set dbRes = Nothing
End Sub
