[[20070706152508]]　『マクロでコピーしたハイパーリンクを有効にする』（うに）　ページの最後に飛ぶ

『マクロでコピーしたハイパーリンクを有効にする』（うに）

こんにちは。うにと申します。
しばらく前にこちらで大変お世話になりました。
データの抽出に関する質問だったのですが、またそれに関連したことをお尋ねいたします。

データは「シートＡ」に、Ａ５からＡＹ２５０まで入っています。
この内Ｒ５からＴ２５０にある語句をキーワードとし、コンボボックスに
それらの語句を格納して、選択された語句を含むデータを「シートＢ」に
抽出します。

ここまで前回ご教示いただいたマクロでできています。

今回お尋ねしたいのは、「シートＡ」のＥ列に配置したハイパーリンクについてです。

Ｅ５からＥ２５０まで、書類ＮＯ．が入っており、その書類（ＰＤＦファイル）を
リンクさせています。

「シートＢ」にデータを抽出する際にこのハイパーリンクを有効にしたいのです。

どうかよろしくお願いいたします。

Exel2002、WindowsXP　です。

下に現在使用しているマクロをお知らせいたします。

Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False
    Sheets("シートA").Select
    ActiveSheet.Unprotect password:="＊＊"

    Dim j As Integer, n As Integer, y As Integer, i As Long
    Dim data As String, tbl
    With Sheets("シートA")
        tbl = .Range("a5").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 51).Value
        data = ComboBox1.Value
    End With
    ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2))
    For i = 1 To UBound(tbl, 1)
        For n = 18 To 20
            If tbl(i, n) = data Then
                y = y + 1
                For j = 1 To UBound(tbl, 2)
                    x(y, j) = tbl(i, j)
                Next j
            End If
        Next n
    Next i
    If y = 0 Then MsgBox "該当するデータはありません": Exit Sub
    ActiveSheet.Protect password:="＊＊", DrawingObjects:=True, Contents:=True, Scenarios:=True
    With Sheets("シートB")
    Sheets("シートB").Select
    ActiveSheet.Unprotect password:="HG"
        .Cells(5, 1).Resize(y, UBound(tbl, 2)) = x
        .Select
    End With
    UserForm1.Hide
    Sheets("シートB").Select
    ActiveSheet.Protect password:="＊＊", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Private Sub UserForm_Initialize()

    Dim dic As Object, c, ky, tbl
    Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("シートA")
        tbl = .Range("s5").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 3).Value
    End With
        ReDim x(1 To UBound(tbl, 1) * 3, 1 To 1)
        For Each c In tbl
            If Not IsEmpty(c) And Not dic.exists(c) Then
                i = i + 1
                dic(c) = Empty
                x(i, 1) = c
            End If
        Next c
    Sheets.Add
    With ActiveSheet
        .Cells(1, 1).Resize(i) = x
        .Range("a1").Resize(i).Sort Key1:=.Range("a1"), Order1:=xlAscending, MatchCase:=False, _
            SortMethod:=xlPinYin
        tbl = .Cells(1, 1).Resize(i).Value
        Application.DisplayAlerts = False
        .Delete
    End With
    With ComboBox1
        For i = 1 To UBound(tbl, 1)
            .AddItem tbl(i, 1)
        Next i
    End With
    Set dic = Nothing
    Application.DisplayAlerts = True
 End Sub

 自動記録でハイパーリンクを設定してみては？
 こんなのが記録されましたけど･･･

 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="aaa.pdf", _
        TextToDisplay:= "D:\User\aaa.pdf"

 (tomo)

tomoさん、ありがとうございます。

説明不足で申し訳ありません。抽出される対象データは246件あり、今後も増えていきます。

そして、「シートA」上では、その1件ずつにハイパーリンクが設定されています。

前回提示しましたマクロでは、「シートA」からキーワードによって抽出されたデータを
「シートB」に転記するようになっています（キーワードによってデータ数は変動します）。

この「シートB」に転記されたE列の書類NO.からも、「シートA」で設定されているものと
同じPDFファイルを開けるようにしたいのです。

このWorkBookは会社で使用しており、社内の共通フォルダに格納されていて、社内の人が
簡単に情報を閲覧できるように作ったものなのです。

ですから、デーを抽出して「シートB」に転記するマクロの中で、ハイパーリンクを有効なまま
ペーストしたいと思っています。

ややこしい話で申し訳ありません。

どうぞよろしくお願いいたします。

（うに）

 前回の質問を知らなく，シート構成がよく分からず，的確なアドバイスが出来ませんが，
 シートＢの変数 = Sheets("シートA").Cells(X,Y) と代入している部分をコピペで表現するようにすれば，行けると思うのですが･･･

 力になれず，すいません･･･
 こちらでもステップインでコードの状況を確認できれば，何とかなるのですが･･･

 (tomo)

 前回内容はこちらでしょうね。
[[20061214152122]]

 とりあえず
tblおよびxが持っているのは値だけなので、そのままひょいと変更して出来るものではないでしょう。
扱う内容をRange型として扱うように変更してあげる、つまりセルをまるっと扱うようにして、
それを貼り付けるような形のマクロを作成することになると思います。

 あるいは
貼り付けられた結果を元にシートAを逆に辿りハイパーリンクに関する情報を取得、
それをtomoさんが提示されたような形で該当セルにAddしてあげる形になるのかなと。
（ご近所PG）作る気は無いのでアドバイスだけ

返事が遅くなり申し訳ありません。

tomoさん、ご近所PGさん、アドバイスありがとうございます。

ご近所PGさんが貼り付けてくださった前回の内容のとおり、最初の質問時に提示したマクロは、

ほとんどこちらの掲示板で作っていただいたもので、私のデータの表に変更があるたび

セル番地などを書き換えていたものです。

お恥ずかしい話ですが、私自身内容をきちんと理解できていたものではなくて、

ご教示いただいたものをコピペして、ところどころ加工して使っています。

そういったわけで、もろ初心者ですので、せっかくアドバイスいただいているのに、

どうしたらよいのかわからない状況です。

お手数をおかけして申し訳ないのですが、どこをどういった形に変えたらよいのか、

もう一度教えていただけないでしょうか？

よろしくお願いいたします。

（うに）

 ハイパーリンクなどと云う難しい事は分かりまへんねんけど、tomoはんが書いてはる
 みたいに単にコピペすればそのハイパーリンクとやらもひっついてくるんでっか？
 もしそれでOKやったらこれでどうでっか？
 　　　　（弥太郎）
 '---------------
 Sub test()
'Private Sub CommandButton1_Click()
    Dim j As Integer, n As Integer, y As Integer, i As Long
    Dim data As String, tbl As Range

    Application.ScreenUpdating = False
    Sheets("シートA").Select
    ActiveSheet.Unprotect password:="＊＊"

    With Sheets("シートA")
        Set tbl = .Range("a5").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 51) '.Value
        data = .Range("a1")
        'data = ComboBox1.Value
    End With
    'ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2))
    With Sheets("シートB")
    For i = 1 To tbl.Rows.Count 'UBound(tbl, 1)
        For n = 18 To 20
            If tbl(i, n) = data Then
                y = y + 1
               tbl(i, 1).Resize(, 51).Copy .Cells(4 + y, 1)
'                y = y + 1
'                For j = 1 To UBound(tbl, 2)
'                    x(y, j) = tbl(i, j)
'                Next j
            End If
        Next n
    Next i
    End With
'    If y = 0 Then MsgBox "該当するデータはありません": Exit Sub
'    ActiveSheet.Protect password:="＊＊", DrawingObjects:=True, Contents:=True, Scenarios:=True
   ' With Sheets("シートB")
'    Sheets("シートB").Select
'    ActiveSheet.Unprotect password:="HG"
'        .Cells(5, 1).Resize(y, UBound(tbl, 2)) = x
'        .Select
'    End With
'    UserForm1.Hide
'    Sheets("シートB").Select
'    ActiveSheet.Protect password:="＊＊", DrawingObjects:=True, Contents:=True, Scenarios:=True
 End Sub

こんにちは、うにです。

ああ！弥太郎さん！お師匠様！！お久しぶりでございます。

その節は本当にお世話になりました。・・・で、またお世話になります（汗）

お師匠様、マクロのご提示ありがとうございます。

早速またコピペして動かしてみましたが、UserForm1の語句を選択して、

CommandButton１を押したところで、とまってしまいました。

文頭に「’」がついているところが緑色になっていましたので、

全部とってしまうと、今度は　　UBound(tbl,2)のところで、「配列がありません」

と、エラーメッセージが出てしまい、うまく動かせませんでした。

本当に、お手数ばかりかけて申し訳ありませんが、どうかお力を貸してください。

よろしくお願いいたします。

（うに）

 これは、コピーすればその「ハイパーリンク」とかいうもんが有効になるんかどうか
 試してみるマクロでっせ。
 シートAのA1にコンボボックスのどれかを入力してtestを実行すればコマンドボタンで
 選択したのと同じようにデータが 必要分シートBにコピペされる筈ですワ。
 結果あんさんの望んでいるハイ・・・が有効になってるかどうかなんですけど？
 有効であれば不要なコードを削除すればよろしいかと思います。
 また、無効なら、捨ててくらはい。
  　　　　　（弥太郎）

こんにちは、うにです。

弥太郎師匠・・・遅くなって申し訳ありません！！

師匠のおっしゃるとおりにしたら、リンクが有効なままコピーできました！！

すごい！

で、さっそく元のマクロの組み込もうとしたんですが、うまくできませんでした。

不要なコードというのは　あたまに「’」がついたところだと思ってやってみたのですが・・・。

じゃあ、動作を別立てにして新しいボタンを作って・・・と思いやってみましたが、これもうまくできませんでした。

できれば一連の動作でやりたいのですが、ご教示いただいたマクロのどこを削って、加工すればよいのか教えてください。

どうぞよろしくお願いいたします。

（うに）

 うにはん遅くなってごめんなはれや。
 忙しさにかまけて見落としとりました。せんせぇんとこのHPでご指摘を受けまして、や
 っと気付いた次第です。（汗

 こんな塩梅でどうでっか？
 パスワード云々は省略しとりますから、それはそちらで組み込んでくらはい。
 　　　　　　　　　　　（弥太郎）
 '----------------------
 Private Sub CommandButton1_Click()
    Dim n As Integer, y As Integer, i As Long
    Dim data As String, tbl As Range

    Application.ScreenUpdating = False
    Sheets("シートA").Select
    ActiveSheet.Unprotect password:="＊＊"

    With Sheets("シートA")
        Set tbl = .Range("a5").Resize(.Range("a" & Rows.Count).End(xlUp).Row - 4, 51) '.Value
        data = ComboBox1.Value
    End With
    With Sheets("シートB")
    For i = 1 To tbl.Rows.Count
        For n = 18 To 20
            If tbl(i, n) = data Then
                y = y + 1
               tbl(i, 1).Resize(, 51).Copy .Cells(4 + y, 1)
            End If
        Next n
    Next i
    End With
 End Sub

こんにちは、うにです。

いえいえ、お師匠様。私のほうこそいつもいつも返信が遅くて恐縮です。

実はまだ組み込み作業がうまくいってなくて、動作が確認できていません。

今までほかの仕事にかかっていましたので、明日以降じっくりと確認させていただきます。

本当にいつもお世話になって・・・。

ありがとうございます！！

では、また後日ご報告いたしますね。

（うに）

こんにちは、うにです。

弥太郎お師匠様、アドバイス下さった皆様、ありがとうございます。

目的どおりにハイパーリンクごとのコピーができました。

本当に感謝いたしております。

またわからなくなったら、ここにきてお尋ねしますので、あきれず見捨てず、

どうぞよろしくお願いいたします。

ありがとうございました。

（うに）

コメント返信：

[ 一覧(最新更新順) ]

[[20070706152508]] 『マクロでコピーしたハイパーリンクを有効にする』（うに） ページの最後に飛ぶ

[[20070706152508]]　『マクロでコピーしたハイパーリンクを有効にする』（うに）　ページの最後に飛ぶ