お世話になります。
ＶＢＡ初心者です。
（初心者でもないのですが、しばらく遠ざかっていました。）
エクセルＶＢＡの記述内容をコピーし、
エクセルの通常のシートへ貼り付けした際、
記述上「’」で始まる文字は緑色が付いていますが、
通常のシートへ貼り付けした際、黒字になってしまいます。
そこで、下記の様なＶＢＡを記述し、貼り付け後に、
「’」から始まる文字を緑色に着色しようと試みましたが
（やはり）うまくいきませんでした。
エクセル関数なんかも織り交ぜたおかしな記述だと思いますが
何となくやりたい事が伝わって頂けるかと思うのですが、
どう修正したら出来ますでしょうか。
ご教授下さいます様、宜しくお願いいたします。
記
Sub 色()
Dim y As Integer
Dim x As Integer
Dim a As Integer
mysheet = ActiveSheet.Name
For y = 1 To 10
x = Sheets(mysheet).Cells(Rows.Count, y).End(xlUp).Row
a = 0
Do Until a > x
a = a + 1
If Right(Cells(y, a), 1) = "'" Then
Cells(y, a).Select
Selection.Font.ColorIndex = 10
End If
Loop
Next
End Sub
VBAでオートシェイプのグループ化についての質問です。
オートシェイプ線（Line）で台形を作成し全てを選択し、グループ化したいと考えています。
また、連続して台形を作成していきたいと考えています。
?4本線を引く
?グループ化（Aグループ）
?4本線を引く
?グループ化（Aグループ）
⇒ 連続して作成・・・
Dim st() As Variant
Dim ob As Shape
Dim MyLine As Shape
'線の作成
Set MyLine = ActiveSheet.Shapes.AddLine(startX, startY, widthX, heightY)
'線の選択
For Each ob In ActiveSheet.Shapes
ReDim Preserve st(j)
st(j) = ob.name
j = j + 1
Next ob
'グループ化
Worksheets("test").Shapes.Range(st).Select
Selection.ShapeRange.Group.Select
と上記コードで一つのグループは作成出来たのですが、次に作成すると
Worksheets("test").Shapes.Range(st).Select
Selection.ShapeRange.Group.Select
でエラーになります。
恐らく前のグループ化内の線も選択してしまうのではないかと思っていますが、対処の仕方が解りません。
線の作成方法から選択方法等いろいろ意見が聞きたいと思っています。
アドバイスよろしくお願いいたします。
m(__)m
下記のマクロで、ファイル指定保存をする時に
"実行時エラー91 オブジェクト変数またはWithブロック変数が設定されていません”がでます。
やりたいのは、選択したセルの１番目をファイル名として
保存をしたいのですが、うまくいきません。
どうしたらよいのでしょうか？
Sub Macro1()
Dim セル As Object
Dim i As Long
i = 1
For Each セル In Selection
Worksheets("Sheet2").Cells(1, i).Value = セル
i = i + 1
Next
ActiveWorkbook.SaveAs Filename:="D:\TEST\" & セル & ".xls"
End Sub
質問タイトルをどのようにしたらよいかわからなかったんですが、
エクセル表を2ページにわたり同じように作った場合、印刷は当然すべての項目が印刷されますが、作成において、表示を一部同じ項目は省略または非表示にする方法を教えてください。
印刷は、 A
B
C となるが、
作成中は、 B
C の表示のみとなる方法です。
エクセルにあまり詳しくなくて、説明も十分でありませんが、よろしくお願いいたします。
エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？
merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、
課名D16
商品名B20:B39
枚数H20:H39
金額I20:I39
の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？
もとのブックの行数は決まっています。
どうか力を貸してください。よろしくお願いします。
Sub test02()
Dim MyFile As String, MyPath As String '変数宣言
Dim x As Long, y As Long
Dim wb As Workbook, tb As Workbook
Dim ka As String
Dim sh1, sh2
Set tb = ThisWorkbook
MyPath = tb.Path & "\" '自分のパスを取得
MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル
Application.ScreenUpdating = False '画面更新停止
Application.Calculation = xlCalculationManual '自動計算停止
Do While MyFile <> "" 'エクセルファイルがなくなるまで
If MyFile <> tb.Name Then '自分以外のファイルを対象
Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く
With ActiveSheet
ka = .Range("D16").Value '課名取得
x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
sh1 = .Range("B20:B" & x).Value '商品名取得
sh2 = .Range("H20:I" & x).Value '数量＆金額取得
End With
With tb.Sheets("Sheet1")
y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
y = IIf(.Range("B" & y) = "", y, y + 1)
If x >= 20 Then '納品書B20以下にデータがあれば
Set myRng = .Range("A" & y).Resize(x - 19, 1)
myRng.Value = ka '課名転記
myRng.Offset(, 1).Value = sh1 '商品名転記
myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記
End If
End With
wb.Close (False) '選択したファイルを閉じる
End If
MyFile = Dir() '次のファイルを検索
Loop '繰り返し
Application.Calculation = xlCalculationAutomatic '自動計算停止解除
Application.ScreenUpdating = True '画面更新停止解除
Set tb = Nothing
Set wb = Nothing
Set myRng = Nothing
End Sub
実行時エラー９：インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。
以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートＡの中のデータを取り上げて、コピーしたいです。けど、エラーが出てきた。皆さん。よろしくお願いします。
Sub test()
Dim forName, bookName As String
Dim x, y, l As Long
Const cnsDIR = "\*.xls"
Dim bFound As Boolean
Dim myBook, actBook As Workbook
Dim mySheet, actSheet As Worksheet
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
myPath = .SelectedItems(1)
End If
End With
forName = Dir(myPath, vbDirectory)
If Dir(myPath, vbDirectory) = "" Then
MsgBox "It's nothing!", vbExclamation
Exit Sub
End If
bFound = False
For x = 2 To 7 Step 1
bookName = Dir(myPath & cnsDIR, vbNormal)
Do While bookName <> ""
l = InStrRev(bookName, ".xls")
If Mid(bookName, l - 4, 4) = Format(Cells(4, x), "0000") Then
bFound = True
Exit Do 'hang/lie
Else
bookName = Dir()
End If
Loop
If bFound = False Then
Rtn = MsgBox("This is no found. Do you want to continue?", vbYesNo, "選択")
If Rtn = vbNo Then Exit For
End If
Windows(bookName).Activate
actSheet = ActiveWorkbook.Sheets
For Each actSheet In Worksheets
If ActiveSheet.Name = "A" Then
Application.Union(Range("C55:F55"), Range("H55:I55")).Copy
ThisWorkbook.Sheets(4).Range("B5").PasteSpecial Paste:=xlValues, Transpose:=True
End If
Next
Next x
End Sub
