To shift 5 columns to the upper row, if the upper row is empty

Hi. This code works now for mw after some editing.

I still have one small problem. Its about the formatting. As I mentioned previously i have a lot of formatting going on. When the code runs i lose the formatting in last few rows. Is it possible to change the last row value to stop before these values?(i.e set last row to row number 52 so that only my table gets altered and not my formatting). I am attached a picture for your understanding. Looking forward to your help eample.jpg

Hi stnkynts,

Thank for your help. I need move the columns only from B23 to H52. Sorry for all XXX. its a company doc so cant leave in it. Once again thx for the help. I am quite new and
still learning

Dear stnkynts,

The code works perfectly. But I have a doubt. when i place the worksheet given above in another workbook with 5 other sheets and try and run the code it gives me Run-time error 1004("Application-defined or object defined error"). Why is that?

Note: I was able to solve this problem by placing this macro in a separate module but I still would like to know what caused the error.

Ya. Intially i put in on the sheet belonging to the code. then when i changed it and added a separate module it worked. Infact I also integrated it with another module i needed and it worked. Just that since i am only starting now my code doesn't seem to be very optimalistic. Takes some time to run. I will share my code here. If possible you to tell me where i can improve?


Sub Copysheets()

Dim DestinationBook As Workbook
Dim LastRow As Integer
Dim strSaveName As String
Dim ws As Worksheet
Dim collValues As Collection
Dim rCell As Range
Dim i As Integer, icolumn As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'get the name to save
Windows(GeneratorFile).Activate
strSaveName = Worksheets("Configuration").Range("I56").Value

'Creating the new workbook
Set DestinationBook = Workbooks.Add
'ActiveWorkbook.SaveAs strSaveName
Application.Dialogs(xlDialogSaveAs).Show (strSaveName)

'Copying data from cells of Sheet1
Windows(GeneratorFile).Activate
Sheets("SMOE-FRONT").Activate
Cells.Select
Range("A11").Activate
Selection.Copy

'Pasting the data of Sheet1 into the new workbook
DestinationBook.Sheets(1).Activate
ActiveSheet.Name = "SMOE-FRONT"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
ActiveWindow.DisplayGridlines = False
Application.CutCopyMode = False
DestinationBook.Save


'Copying data from cells of Sheet2
Windows(GeneratorFile).Activate
Sheets("SMOE-BACK").Activate
Cells.Select
Range("A11").Activate
Selection.Copy

'Pasting the data of Sheet2 into the new workbook
DestinationBook.Worksheets.Add(After:=Worksheets(1)).Name = "Sheet2"
DestinationBook.Sheets("Sheet2").Activate
ActiveSheet.Name = "SMOE-BACK"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
ActiveWindow.DisplayGridlines = False
Application.CutCopyMode = False

'copy
Windows(GeneratorFile).Activate
Sheets("SMOE-FRONT").Activate
ActiveSheet.Shapes.Range(Array("Picture 160")).Select
ActiveWindow.SmallScroll Down:=30
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74")). _
Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74", "Rectangle 169")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74", "Rectangle 169", "Text 74")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74", "Rectangle 169", "Text 74", "Text 74")).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74", "Rectangle 169", "Text 74", "Text 74", "Text 74") _
).Select
ActiveSheet.Shapes.Range(Array("Picture 160", "Rectangle 168", "Text 74", _
"Rectangle 170", "Text 74", "Rectangle 169", "Text 74", "Text 74", "Text 74", _
"Text 124")).Select
Selection.Copy
DestinationBook.Sheets("SMOE-FRONT").Activate
ActiveWindow.SmallScroll Down:=-48
Range("B2:C4").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-3
Selection.ShapeRange.IncrementLeft 7.5
Selection.ShapeRange.IncrementTop 10.5
ActiveWindow.SmallScroll Down:=27
Selection.ShapeRange.IncrementLeft -0.75
Selection.ShapeRange.IncrementTop 3
'This block reactivates the string counting in the label text
Range("T24:T25").Select
ActiveCell.FormulaR1C1 = "=LEN(RC[-10])"
Range("T24:T25").Select
Selection.AutoFill Destination:=Range("T24:T41"), Type:=xlFillDefault
Range("T24:T41").Select
Range("T24:T41").Select
Range("T26").Activate
ActiveWorkbook.Save

'To remove the blanks between lines
Set ws = Sheets("SMOE-FRONT")
Application.ScreenUpdating = False

For icolumn = 3 To 8
If Application.WorksheetFunction.CountA(ws.Range(ws.Cells(23, icolumn), ws.Cells(52, icolumn))) > 1 Then
Set collValues = New Collection
For Each rCell In ws.Range(ws.Cells(23, icolumn), ws.Cells(52, icolumn)).SpecialCells(xlCellTypeConstants)
collValues.Add rCell.Value
Next rCell
ws.Range(ws.Cells(23, icolumn), ws.Cells(52, icolumn)).ClearContents
For i = 1 To collValues.Count
ws.Cells(53, icolumn).End(xlUp).Offset(1, 0).Value = collValues.Item(i)
Next i
Set collValues = Nothing
End If
Next icolumn

Application.ScreenUpdating = True
'end of code to remove blanks
ActiveWorkbook.Save
ActiveWindow.Close



Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

Windows(GeneratorFile).Activate
Sheets("Selector Homepage").Select
End Sub


If you have sometime you can tell what I can avoid here and what to improve on. It would be helpful. But till now thanks for all the help. It helped me a lot.