Copy and paste a column based on a cell's formatting (VBA)

oopss...take out the message box...that was for testing..

:-)
Albert

Try this code:

Sub CheckCells()

Dim RowToSearch, StartingCol, EndingCol As Long

RowToSearch = 6
StartingCol = 7
EndingCol = 22

For i = StartingCol To EndingCol
Cells(RowToSearch, i).Select
If Cells(RowToSearch, i).Borders(xlEdgeRight).LineStyle = xlNone Then
Columns(i + 1).Select
Selection.Copy
Cells(1, i).Select
ActiveSheet.Paste
End If
Next i
   
End Sub


This code will start searching to the line that you want (just input your desired row number instead of 6 in the 'RowToSearch = 6' line), from column G (also, you can change this in the line 'StartingCol = 7') to the column you specify (in the above code it is column V, again you can change this to any column number you prefer). When a cell with no right border is found, then it copies the column in the left of the cell and paste it on the cell's column.

Hope it helps

Exciter.

I like exciter's code better, but when I execute it, nothing pastes as the worksheet looks just as it did before the code ran, except Column V is selected.  Any thoughts?

everythingbutthemoo:
The only way this can happen is if no cell in the specific row and column range you specified in my code has right border.

If you are sure that at least a cell in the range has right border, then could you please upload a sample of your file in a free hosting site so i can check?

Best,
Exciter

Here's the file:  http://www.ee-stuff.com/Expert/Upload/getFile.php?fid=6150

Let me know what you see.

Thanks!

Here is another one...very simple...it prompts you on what cell to start on (enter it as g6 or whatever), then what column to end on (enter it as k or whatever column you want it to end on:

It runs until it reaches the column you told it to end on

Maybe it will help..

:-)
Albert

Sub Test()
    Dim r As Range
    Dim StartRange As String
    Dim ColsToCheck As String
    Dim StartCol As Long
    
        StartRange = InputBox("What cell do you want to start on?")
            If StartRange = "" Then Exit Sub
        ColsToCheck = InputBox("What column do you want to end on?")
            If ColsToCheck = "" Then Exit Sub
            
    Set r = Range(StartRange)
     
    Do Until r.Column > Columns(ColsToCheck).Column
        Set r = r.Offset(0, 1)
        If r.Borders(xlEdgeRight).LineStyle = xlNone Then
            r.Offset(0, -1).EntireColumn.Copy r.EntireColumn
        End If
    Loop
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:

I'm not interested in inputing any information into a Box at this time.  Thank you anyway.

everythingbutthemoo:
It worked fine for me.

The code searched from cell G6 to V6 (RowToSearch = 6, StartingCol = 7, EndingCol = 22) and when it reached cell Q6 it found that it has no right border. It copied column P and pasted it into Column Q. Then it continued copying and pasting columns until it reached cell V6 and stopped. Note that all columns had formatting only and no actual data, because copying started from Column P which is empty.

Let me know if you want me to upload a video of the macro running.

Exciter

A video would be very helpful.  I cannot understand why the code does not copy P and paste it into Q like you say when I run it.  By the way, once the column gets pasted, I do not want any more columns to be pasted.

Thanks!

everythingbutthemoo:
Ok...no problem...I'll let Exciter take over from here...:-)

ps...If either of you upload very many files to EE...here is an automated app that simplifies it a gread deal in case you want to check it out.  It will zip the file for you...log you on, upload the file, then paste the direct link directly in this window (if this window is the last active window)

http://www.experts-exchange.com/Community_Support/Input/Q_22990788.html

:-)
Albert

ahammar:
Great work with the uploader. Thank you very much!

Best
Exciter

Great help!  Thank you so much!

Thank you so much!  That really helped.  If I wanted to PASTE SPECIAL Formats, ColumnWidths, and Fomulas, how would I do that?  Here is the code I am using but for some reason I'm getting an error...

Sub AddNewPredictor()
'
' AddNewPredictor Macro
' Macro recorded 12/13/2007 by Christopher Vesta
'
' Keyboard Shortcut: Ctrl+Shift+A
'
    ActiveSheet.Unprotect ("DBDS11")
   
    Dim RowToSearch, StartingCol, EndingCol As Long
 
    RowToSearch = 6
    StartingCol = 7
    EndingCol = 22
 
    For i = StartingCol To EndingCol
        Cells(RowToSearch, i).Select
        If Cells(RowToSearch, i).Borders(xlEdgeRight).LineStyle = xlNone Then
            Columns(i - 1).Select
            Selection.Copy
            Cells(1, i).Select
            ActiveSheet.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            ActiveSheet.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            ActiveSheet.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Cells(5, i).Select
            Application.SendKeys ("{ESC}"), True
            ActiveSheet.Protect Password:="DBDS11", DrawingObjects:=True, Contents:=True, Scenarios:=True
            Exit Sub
        End If
    Next i
   
       
    ActiveSheet.Protect Password:="DBDS11", DrawingObjects:=True, Contents:=True, Scenarios:=True
   
End Sub

Any last words of wisdom would be very much appreciated!

Thanks again!