ワークシート上にOLEオブジェクトのオプションボタンを配置して、LinkedCellを設定し、同一行でGroupName を設定し、Caption をYesとNoにしようと思いました。
ところが、以下のコードですと、GroupName とCaption がエラーになってしまいます。
どのように直せばいいのでしょうか？
エクセル2003です。
Sub test01()
Dim n As Long, i As Long
With ActiveSheet
For n = 1 To 2
For i = 1 To 3
Set opt = .OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
Left:=.Cells(i, n).Left, Top:=.Cells(i, n).Top, Width:=50, Height:=18)
opt.LinkedCell = .Cells(i, n).Offset(, 4).Address
' opt.GroupName = "OptG" & i
' opt.Caption = IIf(n = 1, "Yes", "No")
Next i
Next n
End With
End Sub
Find関数を使用して検索を行う際に、検索対象のシートに"ヶ月"、"ヵ月"という文字が記載されていると
処理が遅くなってしまします。
解決方法をご存知の方いらっしゃいますでしょうか？
以下、読みにくいプログラムかもしれませんが、ご教授願います。
Sub ボタン1_Click()
Dim value As String
Dim pass As String
Dim template As Workbook
Dim object As Object
'検索対象文字
value = "A"
'テンプレートのパス
pass = "C:\template.xls"
'テンプレートを開く
Set template = Workbooks.Open(pass)
'テンプレートをコピー
ActiveWorkbook.Sheets.Copy
'テンプレートを閉じる
template.Close saveChanges:=False
With ActiveWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(10000, 256))
'テンプレートにAという文字が存在するかのチェック
Set object = .Find(What:=value, LookAt:=xlPart, SearchOrder:=xlByRows)
Do
'存在しない場合は処理を終了
If object Is Nothing Then
End
'存在する場合はA→Bに置き換える
Else
object = Replace(object, value, "B")
End If
'引き続きSheet2にAという文字が存在するかのチェック
Set object = .Find(What:=value, LookAt:=xlPart, SearchOrder:=xlByRows)
Loop While Not object Is Nothing
End With
End Sub
Find関数を使用して検索を行う際に、検索対象のシートに"ヶ月"、"ヵ月"という文字が記載されていると
処理が遅くなってしまします。
解決方法をご存知の方いらっしゃいますでしょうか？
以下、読みにくいプログラムかもしれませんが、ご教授願います。
Sub ボタン1_Click()
Dim value As String
Dim pass As String
Dim template As Workbook
Dim object As Object
'検索対象文字
value = "A"
'テンプレートのパス
pass = "C:\template.xls"
'テンプレートを開く
Set template = Workbooks.Open(pass)
'テンプレートをコピー
ActiveWorkbook.Sheets.Copy
'テンプレートを閉じる
template.Close saveChanges:=False
With ActiveWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(10000, 256))
'テンプレートにAという文字が存在するかのチェック
Set object = .Find(What:=value, LookAt:=xlPart, SearchOrder:=xlByRows)
Do
'存在しない場合は処理を終了
If object Is Nothing Then
End
'存在する場合はA→Bに置き換える
Else
object = Replace(object, value, "B")
End If
'引き続きSheet2にAという文字が存在するかのチェック
Set object = .Find(What:=value, LookAt:=xlPart, SearchOrder:=xlByRows)
Loop While Not object Is Nothing
End With
End Sub
excel2000を利用しています。
■状況
・「実験フォルダ」という名前のフォルダがあります
・「実験フォルダ」の中に「差し込み表示.xls」という名前のファイルがあります
・「実験フォルダ」の中に「実験データ.xls」という名前のファイルがあります。
■やりたいこと
・「実験データ.xls」のファイルデータを参照して、「差し込み表示.xls」のファイルにデータを表示させたい。
・検索するキーは日付（「実験データはＢ列、差し込み表示はＥ５セル」です。
■状況
自分で作ったコードだと値がみつかりません、となって、うまくデータを転記して表示してくれません。
■お願いしたいこと
コードの修正アドバイス、もしくは、他にもっといいプログラムがあるなどのアドバイスがあればいただけるとありがたいです。
■うまくいかないコード
Option Explicit
Sub datatyuusyutu()
On Error Resume Next
Const sashikomiDisplay As String = "差し込み表示.xls"
Const dataFile As String = "実験データ.xls"
Dim i As Long
Dim j As Long
Dim k As Long
Dim objectionrow As Long
Dim lastRow As Long
Dim targetDate As String
Dim targetTime As String
Dim data(1 To 43) As Double
Dim dataFindFlag As Boolean
Dim 対象フォルダ As String
'検索する年月日を取得
targetDate = Range("E5").Value
MsgBox targetDate
対象フォルダ = ThisWorkbook.Path & "\"
Workbooks.Open 対象フォルダ & dataFile
lastRow = Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を得る
MsgBox lastRow
'年月日で検索
For i = 2 To lastRow
If Cells(i, 2) = targetDate Then
Cells(i, 2).Select
dataFindFlag = True
For k = 1 To 43
data(k) = Cells(i - 1, k)
Next k
Exit For
End If
Exit For
Next i
Windows(sashikomiDisplay).Activate
With Workbooks("実験データ.xls")
If dataFindFlag = True Then
Cells(1, 2) = data(1)
Cells(12, 3) = data(4)
Cells(14, 6) = data(5)
MsgBox "実行しました"
Else
MsgBox "データがありません"
End If
End With
Workbooks(dataFile).Close savechanges:=False
End Sub
Excel2010を使用しております。
A列に「承認」という文字が入ると、その行が保護されるマクロがあります。
今の状態ですと、［校閲］-［シート保護の解除］を押すと解除されてしまいますので
保護を解除する際にパスワードを設定したいのですが上手く行きません。
どうかお助け下さい。宜しくお願い致します。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r, rng As Range
Set rng = Intersect(Target, Columns(1))
If Not rng Is Nothing Then
If ActiveSheet.ProtectContents = True Then
ActiveSheet.Unprotect
End If
For Each r In rng
If r.Value = "承認" Then
r.EntireRow.Locked = True
Else
r.EntireRow.Locked = False
End If
Next r
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True
End If
End Sub
当方Excel2003です。
○フォルダ内に入力用のブック（複数）とまとめ用ブック（一つ）が存在し
○すべてのブックにはシートが一つしかなく、タイトル行の位置はまとめブック含めすべて同じ構成である
○入力用ブックのシート名は「入力」、まとめ用ブックのシート名は「まとめ」である
前提で、入力用ブックのデータ入力域をまとめ用ブックに順次コピーをしようと作成中のものですが、
以下の構文
Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1)
あるいは
With .Worksheets(入力).Range("B3：H3" & Range("H65532").End(xlUp).Row).Copy Destination:=c
の部分について
コピー貼り付け（そのまま）ではなく、
「値のみの貼り付け」に変更するには？
どういうふうに変更したら良いのか
どなたかご教示いただければ幸いです。
よろしくお願いいたします。
Sub 連続貼り付け()
Dim sFile As String
Dim c As Range
Dim myPAth As String
Application.ScreenUpdating = False
sFile = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
myPAth = ThisWorkbook.Path
Do While 0 < Len(sFile)
With ThisWorkbook.Worksheets("まとめ")
Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1)
End With
Select Case sFile
Case ThisWorkbook.Name:
Case Else
With Workbooks.Open(Filename:=myPAth & "\" & sFile, ReadOnly:=True)
With .Worksheets(入力)
.Range("B3：H3" & Range("H65532").End(xlUp).Row).Copy Destination:=c
End With
.Close SaveChanges:=False
End With
End Select
sFile = Dir()
Set c = Nothing
Loop
Application.ScreenUpdating = True
End Sub
excelのvbaでsheet2のA列には1または2または5が入っていて、B列には00542,00984などたくさんの文字列が入っています。
それでA列の数字が2かつB列が2文字目降(054,098)の3文字分が098または099なら、sheet3のA列に0を出力というプログラムを作っています。下記が作成したプログラムなのですが、if文の型が違うというエラーが出たり、エラーが無くても表示されなかったりします。
ご指摘ありましたら、よろしくお願いします。
Sub Macro1()
'
'
Dim i As Long
For i = 1 To 5
If Mid(Sheets(Sheet2).Cells(i, 2), 2, 3) = "'098" Or Mid(Sheets(Sheet2).Cells(i, 2), 2, 3) = "'099" And Sheets(Sheet2).Cells(i, 1) = 1 Then
Sheets(Sheet2).Cells(i, 3).Value = 0
End If
Next
'
'
End Sub
