Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(指定なし : 指定なし)
コピーペースト
投稿日時: 17/11/08 09:52:52
投稿者: akaza

通常コピーペーストの時 行列を入れ替え、リンク貼り付けはできません。
VBAでできる方法があれば教えてください。
よろしくお願いします。

回答
投稿日時: 17/11/08 10:17:59
投稿者: もこな2

ちょっと工夫すれば通常機能でもできそうですが。。。
 
1.コピーしたい範囲をコピー
2.リンク貼り付けを実行
3.リンク貼り付けしたものは「相対参照」になっているので「絶対参照」に修正
4.絶対参照に修正したものをコピー
5.形式を選択して貼り付け(計算式、行列を入れ替える)
 
 
VBAでもできるとおもいますが、どんなコードを書いてどこで詰まっているのかが
わからないとコメントがつきづらいように思います。
 

回答
投稿日時: 17/11/08 10:24:38
投稿者: もこな2

すみません。ちょっと間違えました。
 
(誤)計算式
(正)数式
 
 
あと、相対参照になってる範囲を一括して絶対参照にする方法はわからないですが、
そんなに列がないのであれば、置換すればよいとおもいます
 
A1〜C10に相対参照になっている数式があるとして
A→$A$、B→$B$、C→$C$
にそれぞれ置換すればよいかと

投稿日時: 17/11/08 10:28:46
投稿者: akaza

早速ありがとうございます。
3.のところセル毎に行うと多い場合には手間なので一括でできる方法はありますか?

投稿日時: 17/11/08 11:26:14
投稿者: akaza

解決できました
ありがとうございました

回答
投稿日時: 17/11/08 12:30:29
投稿者: もこな2

引用:
3.のところセル毎に行うと多い場合には手間なので一括でできる方法はありますか?

 
一度文字列にすれば絶対参照に直さなくてもいけますね
 
引用:
3.リンク貼り付けしたものは「相対参照」になっているので「絶対参照」に修正
4.絶対参照に修正したものをコピー
5.形式を選択して貼り付け(計算式、行列を入れ替える)

 
ここを、
3.リンク貼り付けした数式の{=」を適当な文字に置換して数式を文字列にする(例:= → ☆)
4.文字列にしたものをコピー
5.形式を選択して貼り付け(値、行列を入れ替える)
6.貼り付けした文字列のち3.で置き換えた文字を=に置換して数式に復元(例:☆ → =)

回答
投稿日時: 17/11/08 13:05:57
投稿者: もこな2

上記の方法の場合、まれに適当な文字を=に置換しても文字列と認識されたままになるようです。
(過去に遭遇した経験がありますが、今回、回答前にテストしてみましたが発生せず)
 
その場合は、「0」という値を「乗算」か「加算」で貼り付ければ対処できたような
記憶がありますが、今回のテスト時には発生しなかったので「乗算」か「加算」どっちだったのか
そもそも記憶違いか、テストはできなかったです。ごめんなさい

回答
投稿日時: 17/11/08 23:40:51
投稿者: baoo

はじめまして。
 
手動でリンク貼り付けした後に行列を入れ替えようとしても希望するような動作に
ならないと思います。
望まれているのが行列を入れ替えて張り付けた各セルが
コピー元を参照しているようなものと想定してみました。
 
まず、リンク貼り付け後のデータを配列に格納します。
LinkedTranspose1の通常のリンク貼り付けを行う場合は実際にリンク貼り付けをして格納し、
LinkedTranspose1の同等処理とLinkedTranspose2は貼り付けせず直接生成して格納しています。
LinkedTranspose1の同等処理はRangeの相対参照機能を使用して一括格納し、
LinkedTranspose2は一時領域としてのRangeを使用せずに各値を個別格納しています。
 
次に行列を入れ替えて張り付ける処理ですが、
ここでは実際に入れ替えて張り付けるのではなく、
格納した配列の行列を入れ替えたものを貼り付け先に出力しています。

Sub LinkedTranspose1(rngSrc As Range, rngDst As Range)

    Dim varTmp As Variant   '貼り付け先の一時保存用
    Dim varRng As Variant   '貼り付けデータ
    Dim rngTmp As Range     '一時領域
    
    '一時領域を取得
    Set rngTmp = rngDst.Parent.Range(rngDst.Cells(1, 1), rngDst.Cells(rngSrc.Rows.Count, rngSrc.Columns.Count))
    
    '一時領域を一旦保存
    varTmp = rngTmp.Value
    
    '一時領域にリンク貼り付け(通常のリンク貼り付けを行う場合)
    rngSrc.Copy
    rngTmp.Parent.Select
    rngTmp.Select
    rngTmp.Parent.Paste link:=True
    
    '一時領域にリンク貼り付け(Sheet.SelectやRange.Selectをしたくない場合)
'    If rngSrc.Parent Is rngDst.Parent Then
'        rngTmp.Value = "=" & rngSrc.Cells(1, 1).Address(False, False)
'    Else
'        rngTmp.Value = "=" & rngSrc.Cells(1, 1).Address(False, False, External:=True)
'    End If
    
    'リンク貼り付けの数式を配列に入れる
    varRng = rngTmp.Formula
    
    '一時領域の復元
    rngTmp.Value = varTmp
    
    '行列を入れ替えて出力(貼り付け先に指定の範囲内だけ張り付けるか、
    'コピー元サイズに拡張して貼り付けるかは下記を選択)
    rngDst = WorksheetFunction.Transpose(varRng)
    'Range(rngDst.Cells(1, 1), rngDst.Cells(rngSrc.Columns.Count, rng.RowsSrc.Count)).Value _
    '= WorksheetFunction.Transpose(varRng)

End Sub
Sub LinkedTranspose2(rngSrc As Range, rngDst As Range)
    
    Dim varTmp() As Variant
    Dim i As Long
    Dim j As Long
    
    'リンク貼り付けのデータを直接作成
    ReDim varTmp(1 To rngSrc.Rows.Count, 1 To rngSrc.Columns.Count) As Variant
    For i = 1 To UBound(varTmp, 1)
        For j = 1 To UBound(varTmp, 2)
            If rngSrc.Parent Is rngDst.Parent Then
                varTmp(i, j) = "=" & rngSrc.Cells(i, j).Address(False, False)
            Else
                varTmp(i, j) = "=" & rngSrc.Cells(i, j).Address(False, False, External:=True)
            End If
        Next j
    Next i

    '行列を入れ替えて出力(貼り付け先に指定の範囲内だけ張り付けるか、
    'コピー元サイズに拡張して貼り付けるかは下記を選択)
    rngDst = WorksheetFunction.Transpose(varTmp)
    'Range(rngDst.Cells(1, 1), rngDst.Cells(rngSrc.Columns.Count, rngSrc.Rows.Count)).Value _
    '= WorksheetFunction.Transpose(varRng)
    
End Sub

回答
投稿日時: 17/11/10 16:38:01
投稿者: もこな2

baooさんの配列に格納するというアイデアをパクt・・・インスパイアしてマクロを作ってみました。
1。手動でリンク貼り付けして数式を作成
2.マクロで数式の行列入れ替え
というプロセスです

Sub sample05()
Dim 配列 As Variant
Dim Max行 As Integer, Max列 As Integer, x As Integer, y As Integer

Dim 範囲 As Range
Set 範囲 = Application.InputBox("対象セル範囲は?", Type:=8)
    If Err.Number <> 0 Then Exit Sub    ''[キャンセル]ボタンがクリックされた

Max行 = 範囲(範囲.Count).Row
Max列 = 範囲(範囲.Count).Column

配列 = 範囲.Formula
範囲.ClearContents

For x = 1 To Max列 '行
    For y = 1 To Max行 '列
        範囲(1).Offset(x - 1, y - 1).Formula = 配列(y, x)
    Next y
Next x

End Sub

頑張れば、1の工程もマクロ化できるとおもいますが、力尽きたので省略しました。

回答
投稿日時: 17/11/14 09:40:56
投稿者: mattuwan44

Sub test()
    Dim rngFrom As Range
    Dim rngTo As Range
    Dim vv As Variant
    Dim i As Long, j As Long
 
    Set rngFrom = Range("B2").CurrentRegion
    Set rngTo = Range("G2")
     
    rngFrom.Copy
     
    Application.ScreenUpdating = False
    With rngTo
        .Select
        .Worksheet.Paste Link:=True
        ActiveWindow.DisplayFormulas = True
        vv = .Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Formula
        ActiveWindow.DisplayFormulas = False
 
        For i = 1 To UBound(vv, 1)
            For j = 1 To UBound(vv, 2)
                vv(i, j) = Application.ConvertFormula(vv(i, j), xlA1, xlA1, xlAbsolute)
            Next
        Next
        .CurrentRegion.ClearContents
        vv = WorksheetFunction.Transpose(vv)
        .Resize(UBound(vv, 1), UBound(vv, 2)).Value = vv
    End With
End Sub
 
どんな時にこのマクロを起動させるのか、もう少し煮詰めないとだめかも。。。。

回答
投稿日時: 17/11/15 01:12:09
投稿者: もこな2

akaza さんの引用:
通常コピーペーストの時 行列を入れ替え、リンク貼り付けはできません。
VBAでできる方法があれば教えてください。
よろしくお願いします。
一応できたので、ご参考に。
ただ、使用頻度が高くてアドイン化して使い回すなら別ですが、数回の処理であれば一般機能で対応した方がよさそうに思います。(何かあったときの保守がめんどくさそう)
 
Sub sample06()
Dim 配列() As String
Dim x As Integer, y As Integer

'---リンク元の取得--------------------------------------------------------
Dim 範囲1 As Range
    On Error Resume Next
    Set 範囲1 = Application.InputBox("リンク元のセル範囲を指定してください", Type:=8)
    On Error GoTo 0
    If 範囲1 Is Nothing Then Exit Sub '「範囲1」がセットされてなければ処理中断
'--------------------------------------------------------------------------

'---貼付先の取得----------------------------------------------------------
Dim 範囲2 As Range
貼付先:
    On Error Resume Next
    Set 範囲2 = Application.InputBox("リンク先の基準セル(左上のセル)を指定してください", Type:=8)
    On Error GoTo 0
    If 範囲2 Is Nothing Then Exit Sub '「範囲2」がセットされてなければ処理中断
    
    If 範囲2.Count <> 1 Then
        MsgBox ("セル範囲が指定されています" & vbCrLf & "貼付先となる範囲の左上のセルだけ選択してください")
        GoTo 貼付先
    End If
Set 範囲2 = Range(範囲2, 範囲2.Offset(範囲1(範囲1.Count).Column - 1, 範囲1(範囲1.Count).Row - 1))
If Application.WorksheetFunction.CountA(範囲2) > 0 Then
    If MsgBox( _
        "以下の範囲には既にデータがあります。" & vbCrLf & _
        "このまま実行すると元に戻せなくなりますがよろしいですか?" & vbCrLf & vbCrLf & _
        範囲2.Parent.Parent.Name & " " & _
        範囲2.Parent.Name & " " & _
        Replace(範囲2.Address, "$", "") _
        , vbCritical + vbOKCancel) = 2 Then GoTo 貼付先
End If
'--------------------------------------------------------------------------

'---動的2次元配列の宣言----------------------------------------------------
ReDim 配列(1 To 範囲1(範囲1.Count).Row, 1 To 範囲1(範囲1.Count).Column)
'--------------------------------------------------------------------------

'---配列へ計算式のセット---------------------------------------------------
Select Case True
    Case Not 範囲1.Parent.Parent.Name = 範囲2.Parent.Parent.Name 'リンク元と貼付先のブックが違う場合
        For x = 1 To UBound(配列, 1)
            For y = 1 To UBound(配列, 2)
                配列(x, y) = "=[" & 範囲1.Parent.Parent.Name & "]" & 範囲1.Parent.Name & "!" & 範囲1(x, y).Address
            Next y
        Next x
    Case 範囲1.Parent.Parent.Name = 範囲2.Parent.Parent.Name And Not 範囲1.Parent.Name = 範囲2.Parent.Name 'リンク元と貼付先のブック同じ かつ シートが違う場合
        For x = 1 To UBound(配列, 1)
            For y = 1 To UBound(配列, 2)
                配列(x, y) = "=" & 範囲1.Parent.Name & "!" & 範囲1(x, y).Address
            Next y
        Next x
    Case Else '同一ブック、同一シートの場合
        For x = 1 To UBound(配列, 1)
            For y = 1 To UBound(配列, 2)
                配列(x, y) = "=" & 範囲1(x, y).Address
            Next y
        Next x
End Select
'--------------------------------------------------------------------------

'---出力-------------------------------------------------------------------
For x = 1 To UBound(配列, 2) '行
    For y = 1 To UBound(配列, 1) '列
        範囲2(1).Offset(x - 1, y - 1).Formula = 配列(y, x)
    Next y
Next x
'--------------------------------------------------------------------------

'---後処理-----------------------------------------------------------------
Workbooks(範囲2.Parent.Parent.Name).Activate
Worksheets(範囲2.Parent.Name).Select

Set 範囲1 = Nothing
Set 範囲2 = Nothing
'--------------------------------------------------------------------------
End Sub

回答
投稿日時: 17/11/15 09:18:54
投稿者: mattuwan44

Sub test2()
    Dim rngFrom As Range
    Dim rngTo As Range
    Dim r As Range
    Dim vv As Variant
    Dim i As Long, j As Long
 
    On Error Resume Next
    Set rngFrom = Selection
    On Error GoTo 0
    If rngFrom Is Nothing Then Exit Sub
 
    On Error Resume Next
    Set rngTo = Application.InputBox("貼付先選択", "貼付", , , , , , 8)
    On Error GoTo 0
    If rngTo Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    rngFrom.Copy
 
    With rngTo
        Application.Goto .Cells
        .Worksheet.Paste Link:=True
        Set r = .Resize(rngFrom.Rows.Count, rngFrom.Columns.Count)
    End With
 
    vv = r.Formula
    For i = 1 To UBound(vv, 1)
        For j = 1 To UBound(vv, 2)
            vv(i, j) = Application.ConvertFormula(vv(i, j), xlA1, xlA1, xlAbsolute)
        Next
    Next
     
    r.ClearContents
    rngTo.Resize(UBound(vv, 2), UBound(vv, 1)).Formula = WorksheetFunction.Transpose(vv)
    rngTo.Select
End Sub
 
勘違いがあったようなようなので訂正。
あぁ、でもだめだなぁ。。。。
作業用のシートを新たに用意して、一旦そこに貼りつけた後、数式を加工し、
その後貼付先に貼りつける感じじゃないと、余分なセルをいじることになりますね。
 
でも、もう書き直す元気がありません(^^;;

回答
投稿日時: 17/11/15 19:58:35
投稿者: baoo

私のLinkedTranspose2ですが、改めて考えるとFor Nextで直接生成しているのに、
最後にTransposeするのはカッコ悪いですね。
下記に訂正します。
 

Sub LinkedTranspose2(rngSrc As Range, rngDst As Range)
    
    Dim varTmp() As Variant
    Dim i As Long
    Dim j As Long
    
    'リンク貼り付けのデータを行列を入れ替えて直接作成
    ReDim varTmp(1 To rngSrc.Columns.Count, 1 To rngSrc.Rows.Count) As Variant
    For i = 1 To UBound(varTmp, 2)
        For j = 1 To UBound(varTmp, 1)
            If rngSrc.Parent Is rngDst.Parent Then
                varTmp(j, i) = "=" & rngSrc.Cells(i, j).Address(False, False)
            Else
                varTmp(j, i) = "=" & rngSrc.Cells(i, j).Address(False, False, External:=True)
            End If
        Next j
    Next i

    '出力(貼り付け先に指定の範囲内だけ張り付けるか、
    'コピー元サイズに拡張して貼り付けるかは下記を選択)
    rngDst = varTmp
    'Range(rngDst.Cells(1, 1), rngDst.Cells(rngSrc.Columns.Count, rngSrc.Rows.Count)).Value _
    '= varTmp
    
End Sub

トピックに返信