相対的位置関係で貼付
 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　玄関へお回り下さい。
MSFlexGridでコピーしたセルの相対的位置関係で貼付　　　　　　(044)
以前 neptuneさんより他の皆さんのお役に立てるかと思い、送らせて頂ましたと言って送って頂いた分です。以前は圧縮ファイルで紹介していたのですが、今回ここで紹介させて頂きます。
Form に MSFlexGrid1 1個と CommandButton ３個(cmdExit cmdCopy Mpaste) を貼り付けておいて下さい
　 Option Explicit　　 'neptuneさん投稿分　　1999.08.10　(044)

Dim KeyCtrl As Boolean　　　'Ctrl キーが押されているかの判定
Dim KeyClip As Boolean　　　'Shiftキーが押されているかの判定
Dim SelDatCount As Long　　 'セルデータのカウント
Dim SelCopyCount As Long　　'コピーした数のカウント
Dim PosiRow() As Integer　　'コピーしたセルのRow
Dim PosiCol() As Integer　　'コピーしたセルのCol
Dim SelDat() As Variant　　 'セルの内容取得用
Dim strClip As String　　　 'Clipプロパティ用の文字列格納用の変数
Dim R1 As Integer　　　　　 '範囲選択用のRow用
Dim R2 As Integer　　　　　 '範囲選択用のRowSel用
Dim C1 As Integer　　　　　 '範囲選択用のCol用
Dim C2 As Integer　　　　　 '範囲選択用のColSel用
Dim CopyMode As Boolean　　 'Copyボタンクリック時のフラグ　True:Click


Private Sub SPasteClip()
On Error Resume Next
Dim nowRow As Integer　　　 '現時選択されている行
Dim nowCol As Integer　　　 '現在選択されている列

'連続した範囲をペーストする
　　With MSFlexGrid1
　　　　　　nowRow = .Row
　　　　　　nowCol = .Col

　　　　If R1 = R2 Then
　　　　　　.Row = nowRow
　　　　　　.Col = nowCol
　　　　　　.RowSel = nowRow
　　　　　　.ColSel = C2
　　　　　　.Clip = strClip
　　　　Else
　　　　　　.Row = nowRow
　　　　　　.Col = nowCol
　　　　　　.RowSel = R1 + nowRow
　　　　　　.ColSel = C2
　　　　　　.Clip = strClip
　　　　End If

　　End With
　　KeyClip = False
End Sub


Private Sub cmdExit_Click()
　　Unload Me
End Sub


Private Sub cmdCopy_Click()
　　CopyMode = True
　　SubDatCopy
End Sub


Private Sub Form_Load()

　　With MSFlexGrid1

　　　　.Rows = 14
　　　　.Cols = 7
　　　　.TextMatrix(1, 1) = "うし"
　　　　.TextMatrix(1, 2) = "うま"
　　　　.TextMatrix(1, 3) = "ぶた"
　　　　.TextMatrix(2, 1) = "しまりす"
　　　　.TextMatrix(2, 4) = "ひつじ"
　　　　.TextMatrix(3, 3) = "くま"
　　　　.RowHeight(-1) = 350

　　End With
　　KeyCtrl = False
　　KeyClip = False
　　CopyMode = False

End Sub


Private Sub Mpaste_Click()

'貼付け先のセルをクリックして、"貼付け"のボタンをクリックすることで
'任意の場所に次々貼付けできます｡

Dim myRow As Integer
Dim myCol As Integer
Dim I As Integer


　　CopyMode = False

　　If KeyClip = True Then
　　　　SPasteClip
　　　　KeyClip = False
　　　　GoTo Owari
　　ElseIf KeyCtrl = True Then
　　　　'今選択されているポジションを取得しておく
　　　　With MSFlexGrid1
　　　　　　myRow = .Row
　　　　　　myCol = .Col
　　　　End With

　　　　If SelDatCount = 0 Then
　　　　　　KeyCtrl = False
　　　　　　GoTo Owari
　　　　End If
On Error GoTo Owari
　　　 With MSFlexGrid1
　　　 For I = 1 To SelDatCount

　　　　　　　　If I = 1 Then
　　　　　　　　　　.Row = myRow
　　　　　　　　　　.Col = myCol
　　　　　　　　　　.Text = SelDat(I)
　　　　　　　　Else
　　　　　　　　　　.Row = PosiRow(I) - PosiRow(1) + myRow
　　　　　　　　　　.Col = PosiCol(I) - PosiCol(1) + myCol
　　　　　　　　　　.CellBackColor = QBColor(15)
　　　　　　　　　　.CellForeColor = QBColor(0)
　　　　　　　　　　.Text = SelDat(I)
　　　　　　　　End If

　　　　Next I
　　　　　　.Row = myRow
　　　　　　.Col = myCol
　　　　　　.CellBackColor = QBColor(15)
　　　　　　.CellForeColor = QBColor(0)
　　　　End With
　　　　KeyCtrl = False
　　End If

　　CopyMode = False

'　　Debug.Print "grid_click　"; "Ctrl: " & KeyCtrl; "　　Clip: " & KeyClip

　　　　Exit Sub

Owari:
　　For I = 1 To SelDatCount
　　　　PosiRow(I) = 0
　　　　PosiCol(I) = 0
　　　　ReDim SelDat(0)
　　　　KeyCtrl = False
　　　　CopyMode = False
　　Next I

　　Select Case Err.Number
　　　　Case 30009, 30010
　　　　　　Dim msg As String
　　　　　　msg = "コピーの範囲が、セルの外に出てしまいます。"
　　　　　　MsgBox msg
　　End Select

'　　Debug.Print "grid_click　"; "Ctrl: " & KeyCtrl; "　　Clip: " & KeyClip

End Sub

'データを入力してのテストをしていませんので､バグ等ありましたらお許し下さい｡
'Ctrl キーを押しながらクリックしたセルを反転色にして、
'後で（コピー等する前）反転色のセルを調べそのセルの
'内容を変数に代入（コピー先に貼り付け）しています。

Private Sub MSFlexGrid1_Click()
　 If KeyCtrl = True Then
　　　With MSFlexGrid1
　　　　 If .CellBackColor = QBColor(1) Then
　　　　　　'再クリックした場合セル色を元に
　　　　　　.CellBackColor = QBColor(15)
　　　　　　.CellForeColor = QBColor(0)
　　　　 Else
　　　　　　'セルに反転色を指定
　　　　　　.CellBackColor = QBColor(1)
　　　　　　.CellForeColor = QBColor(15)
　　　　 End If
　　　 End With
　 End If
End Sub


Private Sub SubDatCopy()

　　Dim I As Integer
　　Dim J As Integer

　　If KeyCtrl = True Then
　　　　SelCopyCount = 0
　　　　SelDatCount = 0
　　　　'表示を早くするために一旦非表示に設定
　　　　With MSFlexGrid1
　　　　　 .Visible = False
　　　　　 '固定列は除く
　　　　　 For I = .FixedCols To .Cols - .FixedCols
　　　　　　　'固定行は除く
　　　　　　　For J = .FixedRows To .Rows - .FixedRows
　　　　　　　　 .Row = J
　　　　　　　　 .Col = I
　　　　　　　　 '反転色のセルを探す
　　　　　　　　 If .CellBackColor = QBColor(1) Then
　　　　　　　　　　SelDatCount = SelDatCount + 1
　　　　　　　　　　'データ、セルの位置を変数に格納しておく
　　　　　　　　　　ReDim Preserve SelDat(SelDatCount) As Variant
　　　　　　　　　　ReDim Preserve PosiRow(SelDatCount) As Integer
　　　　　　　　　　ReDim Preserve PosiCol(SelDatCount) As Integer

　　　　　　　　　　'位置
　　　　　　　　　　PosiRow(SelDatCount) = J
　　　　　　　　　　PosiCol(SelDatCount) = I

　　　　　　　　　　'又はコピー先を指定して直接コピー
　　　　　　　　　　SelDat(SelDatCount) = .Text
　　　　　　　　　　.CellBackColor = QBColor(15)
　　　　　　　　　　.CellForeColor = QBColor(1)
　　　　　　　　 End If
　　　　　　　Next J
　　　　　 Next I
　　　　　 .Visible = True
　　　　End With

　　'連続セル(ドラッグによる)
　　ElseIf KeyClip = True Then
　　　　With MSFlexGrid1
　　　　　　R1 = .Row
　　　　　　R2 = .RowSel
　　　　　　C1 = .Col
　　　　　　C2 = .ColSel

　　　　　　strClip = .Clip
　　　　End With
　　End If

End Sub


Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
　　If KeyCtrl = True Then
　　　　Exit Sub
　　End If

　　'Falseの時はShiftを判断する
　　If Shift = vbCtrlMask Then
　　　　 KeyCtrl = True　'Ctrl キーが押された
　　　　 KeyClip = False
　　Else
　　　　 KeyCtrl = False
　　End If
'　　Debug.Print "MouseDown　 "; "Ctrl: " & KeyCtrl; "　　Clip: " & KeyClip
End Sub


Private Sub MSFlexGrid1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'ドラッグした時は、Clipで処理
　　If CopyMode = True Then
　　　　Exit Sub
　　End If

　　If KeyCtrl = False Then
　　　　KeyClip = True
　　Else
　　　　KeyClip = False
　　End If

'　　Debug.Print "MouseUp　 "; "Ctrl: " & KeyCtrl; "　　Clip: " & KeyClip
End Sub

　
操作　１　連続してないセル
１．Ctrlキーを押しながらクリックで選択(複数セル）
２．cmdCopyボタンをクリック
３．貼り付けたい位置をクリック(1セルのみで良い)
４．Mpasteボタンをクリック
５．コピーしたセルの相対的位置関係で貼付けられます

操作　２　連続したセル
１．コピーしたいセル範囲をドラッグで範囲選択
２．cmdCopyボタンをクリック
３．貼り付けたい位置をクリック(1セルのみで良い)
４．Mpasteボタンをクリック
５．コピーしたセルの相対的位置関係で貼付けられます
　　　






2003/03/17