Copy merged columns to another sheet's empty coumns using VBA?

B.W.B.
May 26th 2016
Thread is marked as Resolved.

May 26th 2016

#1

Good day to all, super master Excel users

I have couple of merged columns in Sheet1. I need to make subroutine to copy them as Values&Source formatting&columns widths, to another sheet in same workbbook to the second empty column in Sheet2 let's say. I know, merged cells are the devils own work. I must not Use cell formatting "Centre across selection". Also, i need error check when colums(sheet2) exceeded 10,000 or so, then to overwrite first columns, and so on.

Code

Sub Macro1()
'
' Macro1
'
'
    Range("B2:J109").Select
    ActiveWindow.SmallScroll Down:=-93
    Selection.Copy
    Sheets("Reports").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").ColumnWidth = 8.57
    Columns("F:F").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 11.14
    Columns("H:H").ColumnWidth = 9.86
    Columns("G:G").ColumnWidth = 12
    Columns("E:E").ColumnWidth = 9.14
    Columns("E:E").ColumnWidth = 10
    ActiveWindow.SmallScroll Down:=51
    Rows("63:63").RowHeight = 15
    ActiveWindow.SmallScroll Down:=-72
    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.Delete
    Sheets("..........TERMINAL").Select
    Range("A1").Select
End Sub

Display More

Thanks in advance for Your time

Code

Sub Reports()
'
' Reports Macro
'
    Dim source As Worksheet
    Dim destination As Worksheet
    Dim emptyColumn As Long
    Set source = Sheets("..........TERMINAL")
    Set destination = Sheets("Reports")
    'find empty Column (actually cell in Row 2)'
    emptyColumn = destination.Cells(2, destination.Columns.Count).End(xlToLeft).Column
        If emptyColumn > 1 Then
        emptyColumn = emptyColumn + 2
        End If
    Sheets("..........TERMINAL").Range("B2:J109").Copy
        
    Sheets("Reports").Cells(2, emptyColumn).PasteSpecial Paste:=xlPasteValues
 
End Sub

Display More

Jun 7th 2016

#2

Re: Copy merged columns to another sheet's empty coumns using VBA?

Code

Case vbYes
Application.ScreenUpdating = False
'This copies reports on sheet as backup of 14 reports, CountA counts all cell with any sighn in fourth row
        On Error GoTo ERROR2
            Sheets("Reports").Select
            Rows("4:4").Select
            If WorksheetFunction.CountA(Cells(4, 4).EntireRow) > 104 Then
                Columns("EB:EB").Select
                Range(Selection, Selection.End(xlToRight)).Select
                Selection.Delete Shift:=xlToLeft
                Columns("A:J").Select
                Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                Sheets("..........TERMINAL").Select
                Range("B2:J109").Select
                ActiveWindow.SmallScroll Down:=-114
                Selection.Copy
                Sheets("Reports").Select
                Range("B2").Select
                ActiveSheet.Paste
                Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
                Range("H5:J8").Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                ActiveSheet.Shapes.Range(Array("ClearReportsFormCbutton")).Select
                Selection.Delete
                Sheets(1).Activate
                Sheets("..........TERMINAL").Select
    
            Else
                Columns("A:J").Select
                Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                Sheets("..........TERMINAL").Select
                Range("B2:J109").Select
                ActiveWindow.SmallScroll Down:=-114
                Selection.Copy
                Sheets("Reports").Select
                Range("B2").Select
                ActiveSheet.Paste
                Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
                Range("H5:J8").Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                ActiveSheet.Shapes.Range(Array("ClearReportsFormCbutton")).Select
                Selection.Delete
                Sheets(1).Activate
                Sheets("..........TERMINAL").Select
            End If
ERROR2:
    'This deletes...

Display More

I resolved this "problem". This is a part of enormous code. Thanks OzGrid for inspiration

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!

Register Yourself Login

Share

This site uses cookies. By continuing to browse this site, you are agreeing to our use of cookies. More Details Close

Your browser has JavaScript disabled. If you would like to use all features of this site, it is mandatory to enable JavaScript.