ワードのマクロについて教えてください。
以下のようなマクロをボタンに登録しています。
Sub Macro10()
Dim myReg As Object
Dim st As String
Dim match As Variant
Set myReg = CreateObject("VBScript.Regexp")
myReg.Pattern = "\x0d\x0d(|$)"
myReg.Global = True
st = ActiveDocument.Range.Text
ActiveDocument.Range(1, 1).Select
For Each match In myReg.Execute(st)
With Selection
.Find.Text = match.Value
.Find.Replacement.Text = vbCr
.Find.Execute , , , , , , , , , , wdReplaceAll
End With
Next
st = ActiveDocument.Range.Text
If myReg.Test(st) Then _
ActiveDocument.Range.Text = myReg.Replace(st, "")
Set myReg = Nothing
End Sub
ここで教えていただきたいのは，上記のマクロを実行するためにボタンを押した際，実行前にカーソルが置かれていたのと同一の場所に実行後のカーソルを戻す方法です。（ちなにみ上記のマクロを実行する際にカーソルが置かれているのは，空白行ではない行の先頭です。※処理とは関係ないかもしれませんが，念のために。）
そのような処理を行うには，上記のマクロにどのような記述を追加すればよいのでしょうか。
どなたかご教示いただければと思います。
どうぞよろしくお願いいたします。
Sub 記入()
Dim testno As String
Dim testrow As Long
Dim basedata(1 To 10) As String
Dim weight(1 To 16) As Double
Sheets("sh3").Select
'(1)
testno = Range("B23").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sheet3").Select
Cells(3, 1) = testno
For i = 1 To 10
Cells(3, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(3, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
'(1)
testno = Range("B24").Value 'No.
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(4, 1) = testno
For i = 1 To 10
Cells(4, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(4, i + 11) = weight(i)
Next i
Sheets("sh3").Select
Erase basedata
Erase weight
この間同様文12個あり
'(1)
testno = Range("B37").Value
If testno = "" Then
End
End If
Sheets("sh1").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 10
basedata(i) = Cells(testrow, i + 1)
Next i
'(2)
Sheets("sh2").Select
For i = 65535 To 6 Step -1
If CStr(Cells(i, 1)) = Trim(testno) Then
testrow = i
Exit For
End If
Next i
If i = 5 Then
MsgBox ("?")
End
End If
For i = 1 To 6
weight(i) = Cells(testrow, i + 1)
Next i
For i = 7 To 12
weight(i) = Cells(testrow, i + 2)
Next i
weight(13) = Application.WorksheetFunction.Max(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(14) = Application.WorksheetFunction.Min(weight(1), weight(2), weight(3), weight(4), weight(5), weight(6))
weight(15) = Application.WorksheetFunction.Max(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
weight(16) = Application.WorksheetFunction.Min(weight(7), weight(8), weight(9), weight(10), weight(11), weight(12))
Sheets("sh3").Select
Cells(17, 1) = testno
For i = 1 To 10
Cells(17, i + 1) = basedata(i)
Next i
For i = 1 To 16
Cells(17, i + 11) = weight(i)
Next i
End Sub
初めて投稿します。
職場でExcel 2000 から Excel 2010へ切り替えがあり
今まで問題なく利用していたマクロがエラーになってしまいました。
修正をして使用したいのですが
マクロ初心者で色々とネットで検索して
ヒントを探ってみたものの
検索の方法がいけないようで、修正方法が見つけられない状態です。
ファイル内にいくつかのシートがあるのですが
シート名に「A」と付くシート数がその都度異なります。
そのシート「*A」とその他のシートをコピーして
新しいファイルとして保存したいのですが
コピーする段階で
【実行時エラー '-2147417848(80010108）’
Copyメゾットは失敗しました；sheetsオブジェクト】
というエラーになってしまいます。
どのように修正すればよいか
教えていただけないでしょうか。
Sub Macro3()
Dim SH As Worksheet
Dim strString As String
Dim sSH1(10) As String
Dim sSH2(30) As String
Dim i As Integer
Worksheets("開始").Activate
sSH1(1) = "あ"
sSH1(2) = "い"
sSH1(3) = "う"
sSH1(4) = "え"
sSH1(5) = "お"
IngCnt = 1
For Each SH In Worksheets
If SH.Name Like "*A*" Then
sSH2(IngCnt) = SH.Name
IngCnt = IngCnt + 1
End If
Next
If IngCnt = 1 Then
strString = sSH1(1)
Else
strString = sSH2(IngCnt - 1)
End If
For i = IngCnt To 30
sSH2(i) = strString
Next i
'↓ここでエラーになります
Sheets(Array(sSH1(2), sSH1(3), sSH1(4), sSH1(5), sSH2(1), sSH2(2), sSH2(3), sSH2(4), _
sSH2(5), sSH2(6), sSH2(7), sSH2(8),sSH2(9), sSH2(10), sSH2(11), sSH2(12), _
sSH2(13), sSH2(14), sSH2(15), sSH2(16), sSH2(17), sSH2(18), sSH2(19), sSH2(20), _
sSH2(21), sSH2(22), sSH2(23), sSH2(24), sSH2(25), sSH2(26), sSH2(27), sSH2(28), _
sSH2(29), sSH2(30))).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\monkey-cr\Desktop\こぴ３.xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
というマクロです。
自宅でも同じようにやってみたのですが
やはりエラーになります。
ただコピーするシート数を減らすと問題なく動くので
エラーメッセージの言うようにシート（数）に問題があるという事までは
分かったのですが
「では、どうする？」というのが…。
勉強不足ですいません。
