Macro to create line at selected location and in multiple workbooks

Superstig666

New member
Joined
Oct 28, 2014
Messages
8
Reaction score
0
Points
0
Hi Folks, long time lurker first time poster!*


I need a macro for 5 workbooks (not sheets) for different teams that would allow me to insert a line based on the row selected in each by just using one of them.


The workbooks are called conduct team, strategy team, planning team, forecast team and results team.


I.e I open up conduct team select a row and run the macro so it creates a line at that selected row and in the other team workbooks too in the same location.*


Can it be done!??


Thank you very much !*

If it can be done once contents were added to this row could it reflect in the other workbooks also.

James
 
yes here are two macros created for each of the scenarios.
Code:
Option Explicit


Sub InsertRowsHere()
'must be in a sheet and on a row e.g. A4
Dim aSheet, oShts
Dim iRow As Long


    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
    iRow = ActiveCell.Row      'get which row
    For Each aSheet In oShts
        Sheets(aSheet).Rows(iRow).Insert
    Next
    
End Sub


Sub CopyRowsHere()
Dim aSheet, oShts, aRange As Range
Dim iRow As Long
'must first select a region to copy e.g. sheet1!A4:C10
    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
     
    Set aRange = Selection
    For Each aSheet In oShts
        If aSheet <> ActiveSheet.Name Then _
            Sheets(aSheet).Range(aRange.Address).Value2 = aRange.Value2
    Next
    
End Sub
 
yes here are two macros created for each of the scenarios.
Code:
Option Explicit


Sub InsertRowsHere()
'must be in a sheet and on a row e.g. A4
Dim aSheet, oShts
Dim iRow As Long


    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
    iRow = ActiveCell.Row      'get which row
    For Each aSheet In oShts
        Sheets(aSheet).Rows(iRow).Insert
    Next
    
End Sub


Sub CopyRowsHere()
Dim aSheet, oShts, aRange As Range
Dim iRow As Long
'must first select a region to copy e.g. sheet1!A4:C10
    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
     
    Set aRange = Selection
    For Each aSheet In oShts
        If aSheet <> ActiveSheet.Name Then _
            Sheets(aSheet).Range(aRange.Address).Value2 = aRange.Value2
    Next
    
End Sub

Super thank you so much I'll check it works when I get in to the office. Many thanks for helping😁
 
Please do not Quote.

this suffices:

Code:
Sub M_snb()
    For Each wb In Workbooks
      wb.Sheets(1).Shapes.AddConnector(1, 0, ActiveCell.Top, 539.4, ActiveCell.Top).Line.Weight = 3
    Next
End Sub
 
yes here are two macros created for each of the scenarios.
Code:
Option Explicit


Sub InsertRowsHere()
'must be in a sheet and on a row e.g. A4
Dim aSheet, oShts
Dim iRow As Long


    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
    iRow = ActiveCell.Row      'get which row
    For Each aSheet In oShts
        Sheets(aSheet).Rows(iRow).Insert
    Next
    
End Sub


Sub CopyRowsHere()
Dim aSheet, oShts, aRange As Range
Dim iRow As Long
'must first select a region to copy e.g. sheet1!A4:C10
    oShts = Array("conduct team", "strategy team", "planning team", "forecast team", "results team")
     
    Set aRange = Selection
    For Each aSheet In oShts
        If aSheet <> ActiveSheet.Name Then _
            Sheets(aSheet).Range(aRange.Address).Value2 = aRange.Value2
    Next
    
End Sub

Hi this is what I am after although it only works if the teams are in the same spreadsheet under different tabs. Each team workbook is a separate excel file. How could we change to apply to separate workbooks. They are all saved in folder c: \Teams if that helps? Many thanks
 
Please do not Quote.

this suffices:

Code:
Sub M_snb()
    For Each wb In Workbooks
      wb.Sheets(1).Shapes.AddConnector(1, 0, ActiveCell.Top, 539.4, ActiveCell.Top).Line.Weight = 3
    Next
End Sub

LOL, yeah right I suppose we both misread part of the question.
 
Yes sorry I misread that. Minor changes mostly around changing Sheets(asheet) to Workbooks(asheet).Sheets(1)
Need to check if it is already opened and also presuming it's sheet 1.
Are we to presume the other sheets are opened/closed and also save & close if required
Busy day ahead, I may not get around to it today
 
Don't think so:


Sub M_snb()
For Each wb In Workbooks
 
Code below, assuming that we want to work in sheet1 for each workbook

Code:
Option Explicit
Dim aSheet, oShts
Const sPath As String = "C:\temp\"  'with the trailing backslash


Public Function Arr()
    Arr = Array("conduct team.xlsx", "strategy team.xlsx", "planning team.xlsx", "forecast team.xlsx", "results team.xlsx")
End Function


Sub InsertRowsHere()
'must be in a sheet and on a row e.g. A4
Dim iRow As Long


    If IsEmpty(oShts) Then oShts = Arr    'create the array if it does not exist
    iRow = ActiveCell.Row      'get which row
    
    For Each aSheet In oShts
            Workbooks(aSheet).Sheets(1).Rows(iRow).Insert
    Next
    
End Sub


Sub CopyRowsHere()
Dim aRange As Range
Dim iRow As Long
'must first select a region to copy e.g. sheet1!A4:C10
    If IsEmpty(oShts) Then oShts = Arr    'create the array if it does not exist
     
    Set aRange = Selection
    For Each aSheet In oShts
        If aSheet <> ActiveWorkbook.Name Then _
            Workbooks(aSheet).Sheets(1).Range(aRange.Address).Value2 = aRange.Value2
    Next
    
End Sub


Sub OpenAllFiles()
Dim wb As Workbook
    
    If IsEmpty(oShts) Then oShts = Arr    'create the array if it does not exist
    On Error Resume Next                  'needed as we are calling workbooks which may not be open
    For Each aSheet In oShts
        Set wb = Workbooks(aSheet)
        If wb Is Nothing Then Workbooks.Open (sPath & aSheet)
        Set wb = Nothing
    Next
    On Error GoTo 0
End Sub


Sub CloseAllFiles()
    
    If IsEmpty(oShts) Then oShts = Arr    'create the array if it does not exist
    
    For Each aSheet In oShts
        Workbooks(aSheet).Close (True)
    Next
    
End Sub
 
Last edited:
Many Thanks Wizard of Oz! this works great. One last thing if I only wanted to copy and paste certain cells with in the row what should the code be altered to?

I.e to have the function as before to highlight the row but then only copy cells A10 to H10 and then K10 to P10 and then paste to other workbooks as before (so leaving two cells out in the middle.

Many Thanks!!
 
Many Thanks Wizard of Oz! this works great. One last thing if I only wanted to copy and paste certain cells with in the row what should the code be altered to?

I.e to have the function as before to highlight the row but then only copy cells A10 to H10 and then K10 to P10 and then paste to other workbooks as before (so leaving two cells out in the middle.

Many Thanks!!

Also I now need to store the documents on SharePoint which I have figured out how to update the code you have provided. Is there something we could add in to auto check out and check in the documents?

Again Thank You!
 
Two minor changes in CopyRowsHere (sorry formatting lost in cut and paste)

Code:
Sub CopyRowsHere()
Dim aRange As Range
Dim iRow As Long
[COLOR=#ff0000][B]Const sColumns As String = "A:H,K:P"
[/B][/COLOR]'must first select a region to copy e.g. sheet1!A4:C10    
If IsEmpty(oShts) Then 
oShts = Arr    'create the array if it does not exist         
Set aRange = [COLOR=#ff0000][B]Intersect(Selection, Range(sColumns))[/B][/COLOR]   
For Each aSheet In oShts        
If aSheet <> ActiveWorkbook.Name Then _            
Workbooks(aSheet).Sheets(1).Range(aRange.Address).Value2 = aRange.Value2    
Next    
End Sub
 
Last edited:
Great thank you, do you know a code to use to auto check out and check in documents to SharePoint I could add to this also?
 
I haven't worked with Sharepoint for ages. This code looks promising from http://msdn.microsoft.com/en-us/library/office/aa223820(v=office.11).aspx

Code:
Sub CheckInOut(strWkbCheckIn As String)


    ' Determine if workbook can be checked in.
    If Workbooks(strWkbCheckIn).CanCheckIn = True Then
        Workbooks(strWkbCheckIn).CheckIn
        MsgBox strWkbCheckIn & " has been checked in."
    Else
        MsgBox "This file cannot be checked in " & _
            "at this time.  Please try again later."
    End If


End Sub


and this from http://msdn.microsoft.com/en-us/library/office/aa223821(v=office.11).aspx

Code:
Sub UseCheckOut(docCheckOut As String)


    ' Determine if workbook can be checked out.
    If Workbooks.CanCheckOut(docCheckOut) = True Then
        Workbooks.CheckOut docCheckOut
    Else
        MsgBox "Unable to check out this document at this time."
    End If


End Sub
 
Back
Top