0

迅速かつ簡単なプロジェクト管理トラッカーを開発しようとしています。現在、入力ボックスを使用して、追加するプロジェクトの名前 (PrjName) を取得しています。次に、コードはテンプレートをコピーし、「プロジェクト」ワークシートの次の使用可能な COLUMN に貼り付けます (プロジェクト間の余分なスペース用に +1)。次に、PrjName をプロジェクトのリストとしてダッシュボード ワークシートに追加したいのですが、プロジェクトが "Projects" ワークシートに貼り付けられた適切な列にリンクするハイパーリンクとして追加します。希望どおりにコピー/貼り付けする方法を理解しましたが、ハイパーリンクの参照の作成を開始する方法さえわかりません。プロジェクト名を使用して、貼り付けられた情報を参照する名前付き範囲を作成し、ハイパーリンクのその名前を参照することでこれを行うことができると思いましたが、これを達成する方法がわかりません. これが私がこれまでに持っているものですが、おそらく正しいとは言えません。

Private Sub CommandButton1_Click()
Dim FirstBlankCol As Range

PrjName = InputBox("Enter the name of the project", "User Input Required")
If PrjName = "" Then Exit Sub

'Find First Blank Cell to add new Project on Summary Worksheet
Set FirstBlankCol = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Worksheets("Summary").Hyperlinks.Add Anchor:=FirstBlankCol, Address:="", SubAddress:= _
"PrjName", TextToDisplay:=PrjName

With Sheets("Projects")
    Select Case Sheets("Projects").Range("A1") = ""
        Case True 'paste in Col A if A1 is empty
            Sheets("Template").Range("A1:F5").Copy
            Sheets("Projects").Range("A1") _
            .PasteSpecial Paste:=xlPasteColumnWidths
            Sheets("Projects").Range("A1") _
            .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        Case False 'paste in next col
            Sheets("Template").Range("A1:F5").Copy
            Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
            .PasteSpecial Paste:=xlPasteColumnWidths
            Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
            .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        End Select
        Application.CutCopyMode = False
End With

End Sub
4

1 に答える 1

0

これを試してください：

Private Sub CommandButton1_Click()

    Dim ws As Worksheet
    Dim wsPrj As Worksheet
    Dim wsTmp As Worksheet
    Dim rngDest As Range
    Dim strProjectName As String

    strProjectName = InputBox("Enter the name of the project", "User Input Required")
    If Len(Trim(strProjectName)) = 0 Then Exit Sub  'Pressed cancel

    Set ws = ActiveSheet
    Set wsPrj = Sheets("Projects")
    Set wsTmp = Sheets("Template")

    Application.ScreenUpdating = False
    If Len(wsPrj.Range("A1").Text) = 0 Then Set rngDest = wsPrj.Range("A1") Else Set rngDest = wsPrj.Cells(1, Columns.Count).End(xlToLeft).Offset(, 6)
    wsTmp.Range("A1:F5").Copy
    rngDest.PasteSpecial xlPasteAllUsingSourceTheme
    rngDest.PasteSpecial xlPasteColumnWidths
    Application.CutCopyMode = False

    ActiveWorkbook.Names.Add Replace(strProjectName, " ", "_"), "='" & wsPrj.Name & "'!" & rngDest.Address
    ws.Hyperlinks.Add ws.Cells(Rows.Count, "B").End(xlUp).Offset(1), "", Replace(strProjectName, " ", "_"), , strProjectName
    Application.ScreenUpdating = True

End Sub
于 2013-08-13T21:23:06.650 に答える