VBA Guidance

S

superfb

Active Member
Joined
Oct 5, 2011
Messages
251
Office Version
  1. 2007
Platform
  1. Windows
Hi All,

I have 15 tabs in a workbook, the last columns in each of the tab have a formula for a specific year. I was wondering if there is a vba code that would indentify the formula in the specific columm, highlight this and copy it in the previous column. i tried recording this action but it specifies the column to highlight which wouldnt work going forward:

VBA Code: 
heets("Table 1").Select
    Cells.Find(What:="=Year", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Columns("AI:AI").Select
    Selection.Copy
    Columns("AI:AI").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 2").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("AI:AI").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 3").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("AI:AI").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 4").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("AI:AI").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 5").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 6").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=-10
    Sheets("Table 7_SIC07").Select
    Selection.FindNext(After:=ActiveCell).Activate
    Selection.FindNext(After:=ActiveCell).Activate
    Sheets("Table 9").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("AI:AI").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 10_SOC20").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 12").Select
    Selection.FindNext(After:=ActiveCell).Activate
    Range("A1").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AI:AI").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 15").Select
    Range("B1").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("AA:AA").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Table 7_SIC07").Select
    Range("A1").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Columns("T:T").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("T:T").Select
    Selection.Insert Shift:=xlToRight
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
End Sub

EDIT:
Maybe thinking about it, if the code searches "=Year", offset code to insert a column before it, then paste special values and do this for each of the tabs?
 
Last edited by a moderator:
Sort by date Sort by votes
It's a start then. Are there any other anomalies, sheet to sheet?
Is row 3 good for all sheets to find the header of last column?
Run the below and see if all sheets and their last rows and last columns get printed to the Immediate Window in the vba editor.
It will be tomorrow before I can do more.

VBA Code: 
Sub Insert_Col()
Dim ws As Worksheet
Dim lr As Long
Dim lc As Long
Dim myrng As Range
Dim myvar As Variant

Application.ScreenUpdating = False
On Error GoTo Oops:
For Each ws In ThisWorkbook.Sheets
'there are are sheets that need to be ignored

Select Case ws.Name

Case "Main Menu", "Notes", "Contents", "Table 8", "Table 11", "Table 13", "Table 14"  ' Sheets to be ignored
GoTo Ignore:

Case Else  'Otherwise do insert
    With ws
    Debug.Print .Name  ' <<<<<< Just for de-bugging
        'last column  by interrogating row 3!!!!!!!!!!
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        'last row
        lr = .Cells(Rows.Count, lc).End(xlUp).Row

      Debug.Print "lr = " & lr
       Debug.Print "lc = " & lc

        'range of interest
        Set myrng = .Range(.Cells(1, lc), .Cells(lr, lc))
        'Assign range values to array myvar
        myvar = myrng.Value
        'insert a new column
        myrng.Columns(1).EntireColumn.Insert
        ' range values to new column
        myrng.Offset(0, -1).Value = myvar
        
    End With
    
    Set myvar = Nothing
    Set myrng = Nothing
    
 End Select
 
Ignore:
Next ws

Oops:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
 
Upvote 0

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Snakehips said:
It's a start then. Are there any other anomalies, sheet to sheet?
Is row 3 good for all sheets to find the header of last column?
Run the below and see if all sheets and their last rows and last columns get printed to the Immediate Window in the vba editor.
It will be tomorrow before I can do more.

VBA Code: 
Sub Insert_Col()
Dim ws As Worksheet
Dim lr As Long
Dim lc As Long
Dim myrng As Range
Dim myvar As Variant

Application.ScreenUpdating = False
On Error GoTo Oops:
For Each ws In ThisWorkbook.Sheets
'there are are sheets that need to be ignored

Select Case ws.Name

Case "Main Menu", "Notes", "Contents", "Table 8", "Table 11", "Table 13", "Table 14"  ' Sheets to be ignored
GoTo Ignore:

Case Else  'Otherwise do insert
    With ws
    Debug.Print .Name  ' <<<<<< Just for de-bugging
        'last column  by interrogating row 3!!!!!!!!!!
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        'last row
        lr = .Cells(Rows.Count, lc).End(xlUp).Row

      Debug.Print "lr = " & lr
       Debug.Print "lc = " & lc

        'range of interest
        Set myrng = .Range(.Cells(1, lc), .Cells(lr, lc))
        'Assign range values to array myvar
        myvar = myrng.Value
        'insert a new column
        myrng.Columns(1).EntireColumn.Insert
        ' range values to new column
        myrng.Offset(0, -1).Value = myvar
       
    End With
   
    Set myvar = Nothing
    Set myrng = Nothing
   
 End Select
 
Ignore:
Next ws

Oops:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Click to expand...
Hiya, the only other anomalies i can think off is that as you go down the table there are gaps in there. I had a look at the intermediate and watch nothing came up - but in the locals - LC is correct at row 3 but the LR isnt capturing the correct number, and as i already mention the cursor doesnt move apart from Table 15
 
Upvote 0
So i think witht he first Macro it copied over data in some random Columns BA,BB,BC and this was causing the issue! It works great now! Thank you so much for that - was really helpful.

One thing, can the code be changed slightly to copy the format over too?
 
Upvote 0
Try this.

VBA Code: 
Sub Insert_Col()
Dim ws As Worksheet
Dim lr As Long
Dim lc As Long
Dim myrng As Range
Dim myvar As Variant

Application.ScreenUpdating = False
On Error GoTo Oops:
For Each ws In ThisWorkbook.Sheets
'there are are sheets that need to be ignored

Select Case ws.Name

Case "Main Menu", "Notes", "Contents", "Table 8", "Table 11", "Table 13", "Table 14"  ' Sheets to be ignored
GoTo Ignore:

Case Else  'Otherwise do insert
    With ws
    
        'last column  by interrogating row 3!!!!!!!!!!
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        'last row
        lr = .Cells(Rows.Count, lc).End(xlUp).Row
      
        'range of interest
        Set myrng = .Range(.Cells(1, lc), .Cells(lr, lc))
        'Assign range values to array myvar
        myvar = myrng.Value
        'insert a new column
        myrng.Columns(1).EntireColumn.Insert
        ' range values to new column
        myrng.Offset(0, -1).Value = myvar
        'Copy format to new column
     myrng.Copy
     myrng.Offset(0, -1).PasteSpecial xlPasteFormats
     Application.CutCopyMode = False
     myrng.Offset(0, -1).ColumnWidth = myrng.ColumnWidth
     
    End With
    
    Set myvar = Nothing
    Set myrng = Nothing
    
 End Select
 
Ignore:
Next ws

Oops:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Snakehips said:
Try this.

VBA Code: 
Sub Insert_Col()
Dim ws As Worksheet
Dim lr As Long
Dim lc As Long
Dim myrng As Range
Dim myvar As Variant

Application.ScreenUpdating = False
On Error GoTo Oops:
For Each ws In ThisWorkbook.Sheets
'there are are sheets that need to be ignored

Select Case ws.Name

Case "Main Menu", "Notes", "Contents", "Table 8", "Table 11", "Table 13", "Table 14"  ' Sheets to be ignored
GoTo Ignore:

Case Else  'Otherwise do insert
    With ws
   
        'last column  by interrogating row 3!!!!!!!!!!
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        'last row
        lr = .Cells(Rows.Count, lc).End(xlUp).Row
     
        'range of interest
        Set myrng = .Range(.Cells(1, lc), .Cells(lr, lc))
        'Assign range values to array myvar
        myvar = myrng.Value
        'insert a new column
        myrng.Columns(1).EntireColumn.Insert
        ' range values to new column
        myrng.Offset(0, -1).Value = myvar
        'Copy format to new column
     myrng.Copy
     myrng.Offset(0, -1).PasteSpecial xlPasteFormats
     Application.CutCopyMode = False
     myrng.Offset(0, -1).ColumnWidth = myrng.ColumnWidth
    
    End With
   
    Set myvar = Nothing
    Set myrng = Nothing
   
 End Select
 
Ignore:
Next ws

Oops:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Click to expand...
Just tried it now - works an absolute treat!!! Thank you soooo much!

Can this code be slightly edited to delete the last column as the final version has duplicated data in the last two columns with the code above
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Please help me clean up my VBA script, I'm having trouble with redundancies
Replies
4
Views
120
CapRavOr
C
C
  • Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
94
myall_blues
myall_blues
P
  • Question
Help with Vba Code
Replies
3
Views
201
Coyotex3
C
P
  • Solved
Counter in For Each loop
Replies
2
Views
234
Possum17
P
excelbytes
  • Solved
VBA Code To Copy Data Into Next Blank Column
Replies
5
Views
157
mumps
mumps

Forum statistics

Threads
1,215,757
Messages
6,126,693
Members
449,331
Latest member
smckenzie2016

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top