Macro to create line at selected location and in multiple workbooks

[Superstig666]

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

[WizzardOfOz]

yes here are two macros created for each of the scenarios.

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

[Superstig666]

yes here are two macros created for each of the scenarios.

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😁

[snb]

Please do not Quote.

this suffices:

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

[Superstig666]

yes here are two macros created for each of the scenarios.

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

[WizzardOfOz]

Please do not Quote.

this suffices:

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.

[WizzardOfOz]

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

[snb]

Don't think so:


Sub M_snb()
For Each wb In Workbooks

[WizzardOfOz]

Code below, assuming that we want to work in sheet1 for each workbook

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

[Superstig666]

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!!