如何将合并单元格，移植到加一个区域．

ningyong58

                用VBA程序，将绿色区域百分百复制到黄土色区域．　                                               
                                                               


          Dim oRange As Range, Rr As Range                                                       
          On Error Resume Next                                                       
          Set oRange = Range("A1:D8")                                                       
          For Each Rr In oRange                                                       
            Rr(1, 6).Value = Rr                                                               
            If Rr.Merge Then                                                               
              Rr.Merge = Rr.MergeArea.Resize        关键是这句话，如何重新定义区域．                       
            End If                                                               
          Next Rr                                                               
        End Sub       

                                                       
Book1.rar (8.77 KB, 下载次数: 8)

2009-12-18 15:37 上传

点击文件名下载附件

alzeng

1. 
   
2. Sub Cpy()
   
3.   Dim Arr
   
4.   
   
5.   Arr = [A1:D6]
   
6.   [F1].Resize(6, 4) = Arr
   
7. End Sub
   

复制代码

ningyong58

原帖由 alzeng 于 2009-12-18 15:47 发表

Sub Cpy()
  Dim Arr
  
  Arr = [A1:D6]
  [F1].Resize(6, 4) = Arr
End Sub

没说清楚，不是Copy，而是移植到另一区域，包括合并单元格．

Sub ll()
  Dim oRange As Range, Rr As Range, Rrr As Range
  On Error Resume Next
  Set oRange = Range("A1:D8")
  For Each Rr In oRange
    Rr(1, 6).Value = Rr
    'Debug.Print Rr.MergeCells
    If Rr.MergeCells Then
      Debug.Print Rr.MergeArea.Address, Rr.MergeArea.Rows.Count, Rr.MergeArea.Columns.Count
      Set Rrr = Rr.Resize(Rr.MergeArea.Rows.Count, Rr.MergeArea.Columns.Count) '.Offset(1, 6)   
      Rrr.Select
    End If
  Next Rr
End Sub

Set Rrr = Rr.Resize(Rr.MergeArea.Rows.Count, Rr.MergeArea.Columns.Count) '.Offset(1, 6)
也就是将这个区域　offset 到另一个区域，合并．

另一种办法
Sub ll()
  Dim oRange As Range, Rr As Range, Rrr As Range, Rs1 As Range
  On Error Resume Next
  Set oRange = Range("A1:E9")
  For Each Rr In oRange
   
    'Debug.Print Rr.MergeCells
   
    If Rr.MergeCells Then
      With Rr.MergeArea
        n1 = .Row
        n2 = n1 + .Rows.Count
        c1 = .Column + 6
        c2 = c1 + .Columns.Count + 6
      End With
      Debug.Print Rr.MergeArea.Address, n1, c1, n2, c2
      Set Rs1 = Range(Cells(n1, c1), Cells(n2, c2))
      Rs1.Select
      'Rs1.MergeCells = True
      Rs1.Select
    End If
  Next Rr
End Sub

[ 本帖最后由 ningyong58 于 2009-12-18 18:08 编辑 ]

ningyong58

用Range(cells1,cells2)方法

Sub ll()
  Dim oRange As Range, Rr As Range, Rrr As Range, Rs1 As Range
  Dim Tt As String, rowNo
  On Error Resume Next
  Set oRange = Range("A1:E9")
  rowNo = 1
  For Each Rr In oRange
    'Debug.Print Rr.MergeCells
    Sheet2.Cells(rowNo, 1) = Rr.Address(2, 3, xlR1C1)
    Sheet2.Cells(rowNo, 2) = Rr
    Rr.Offset(0, 6) = Rr
    If Rr.MergeCells Then
      If Rr.MergeArea.Address(2, 3, xlR1C1) <> Tt Then
       With Rr.MergeArea
        n1 = .Row
        n2 = .Rows.Count
        c1 = .Column + 6
        c2 = .Columns.Count  ' + 6
        
          Range(Cells(n1, c1), Cells(n1, c1)).Resize(n2, c2).MergeCells = True
        Tt = Rr.MergeArea.Address(2, 3, xlR1C1)
        Debug.Print Tt
       End With
      End If
    End If
  Next Rr
End Sub

[ 本帖最后由 ningyong58 于 2009-12-18 22:28 编辑 ]

ningyong58

目标基本实现
Sub oCells()
  Dim oRange As Range, Rr As Range
  'Set oRange = Sheet6.Range(Cells(2, 2), Cells(5, 3))
  Set oRange = Sheet6.Range("B2:C5")
  pp = oRange
  Set Rr = oRange.Offset(4, 3).Resize(4, 2)
  With Rr
        Rr(1).ColumnWidth = oRange(1).ColumnWidth
        Rr(2).ColumnWidth = oRange(2).ColumnWidth
        .HorizontalAlignment = oRange.HorizontalAlignment
        .VerticalAlignment = oRange.VerticalAlignment
        .WrapText = oRange.WrapText
        .Orientation = oRange.Orientation
        .AddIndent = oRange.AddIndent
        .Font.Size = oRange.Font.Size
        .Font.Name = oRange.Font.Name
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        .MergeCells = True
  End With
End Sub

ningyong58

Function RcMergeCells(oSheet, oRStr As String, rowNo, colNo) As Range
  ''
  Dim Arr, Nn(1), Cc(1)
  Arr = Split(oRStr, ":")
  
  For ii = 0 To UBound(Arr)
    Nn(ii) = Val(Mid(Arr(ii), 2))
    Cc(ii) = Val(Mid(Arr(ii), InStr(Arr(ii), "C") + 1))
  Next ii
  If UBound(Arr) = 0 Then
    Nn(1) = Nn(0)
    Cc(1) = Cc(0)
  End If
  ''
  With Sheets(oSheet)
    Set RcMergeCells = .Range(.Cells(Nn(0) + rowNo, Cc(0) + colNo), .Cells(Nn(1) + rowNo, Cc(1) + colNo))
   
  End With
  If UBound(Arr) > 0 Then
    RcMergeCells.MergeCells = True
  End If
End Function

Sub llss()
  Dim oRStr As String, Rr As Range
  
  ''
  
  For ii = 1 To Range("A65366").End(xlUp).Row
    Set Rr = RcMergeCells("Sheet7", Cells(ii, 1), 0, 0)
    Rr(1, 1) = Cells(ii, 2)
   
    Rr(1, 1).Font.Size = Cells(ii, 3)
    'Rr.Font.Size = Cells(ii, 3)
    Rr(1, 1).Font.Name = Cells(ii, 4)
   
    Rr.HorizontalAlignment = Val(Cells(ii, 5))
    Rr(1, 1).VerticalAlignment = Val(Cells(ii, 6))
    'Rr(1, 1).WrapText = Cells(ii, 7)
    'Rr(1, 1).Orientation = Cells(ii, 8)
   
  Next ii
  ''
End Sub