0

連絡先のマスターリストがあります。次の相対参照ポイントを使用するマクロを作成しようとしています。

特定のシートテンプレートを開く=ActiveCellの値またはマクロでアクティブ化された最初のセルの値を指定し、マスターリストから新しいシートに情報をコピーして貼り付けます

シートを開いてコピーと貼り付けを行う方法はわかりますが、シートの名前を変更すると常にエラーが発生します。

ActiveCell.Range("A1,A2:B26").Select
ActiveCell.Offset(1, 0).Range("A1").Activate
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
ActiveCell.Offset(-1, 0).Range("A1").Select
Sheets("Patient List").Select
Sheets.Add Type:= _
    "C:\Users\Valerie\AppData\Roaming\Microsoft\Templates\Patient-History-Template1.xltx"
Sheets("Patient List").Select
Selection.Copy
Sheets("Patient List").Select
Sheets("Patient List").Name = "Patient List"
Sheets("Patient 1").Select

ここで、新しいシートの名前=「Jones」ではなくマクロでアクティブ化された最初のセルの相対値を指定します。このようにして、マクロを実行し、columnAの名前ごとに個別のシートを取得できます。

Sheets("Patient 1").Name = "Jones"
Sheets("Jones").Select
ActiveSheet.Paste
Sheets("Patient List").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Jones").Select
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
Sheets("Patient List").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Jones").Select
ActiveCell.Offset(2, -1).Range("A1").Select
ActiveSheet.Paste
Sheets("Patient List").Select
4

1 に答える 1

2

おそらく、患者名を含むセルの範囲で、これをループで実行する必要があります。

Sub TestAddPatientSheet()
Dim rng As Range
Dim r As Long 'row iterator
Dim patientName As String
Dim patientSheet As Worksheet

Sheets("Patient List").Activate

Set rng = Set rng = Sheets("Patient List").Range("A2:B26")   '<-- this is the range of cells w/patient names in Col A
    For r = 1 To rng.Rows.Count
        patientName = rng(r, 1).Value
        'Creates a new worksheet
        Set patientSheet = Sheets.Add(After:=Sheets("Patient List"), _
            Type:="C:\Users\Valerie\AppData\Roaming\Microsoft\Templates\Patient-History-Template1.xltx")
ResRetry:
        'Attempt to rename the sheet, trapping errors (if any) and allowing re-try
        On Error GoTo ErrName:
        patientSheet.Name = patientName
    Next
Exit Sub

ErrName:
Err.Clear
MsgBox patientName & " is not a valid worksheet name", vbCritical

patientName = InputBox("Please rename the worksheet for " & patientName & "." & _
                        vbCRLF & "Make sure the sheet name doesn't already exist, is " & _
                        "fewer than 32 characters, and does not contain " & vbCRLF & _
                        "special characters like %, *, etc.", "Rename sheet for " & patientName, patientName)
Resume ResRetry


End Sub
于 2013-03-27T00:07:51.903 に答える