I would like to insert the user name of the 'creator' (person who inserts) new row. I want the user name entered in column G.
I currently have the following macro to insert the row:
Sub Insert_Row()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "H").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteFormulas
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You just need to track the inserted row and set column G to the username, like this:
Sub Insert_Row()
Dim rActive As Range
Dim insertRow As Long
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "H").End(xlUp)
insertRow = .Row + 1
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteFormulas
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
Cells(insertRow, "G").Value = Environ("Username")
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
Code:-
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").Select
ActiveCell.FormulaR1C1 = "p"
Range("C1").Select
Selection.AutoFilter
ActiveSheet.Range("A1", Range("C" & Rows.Count).End(xlUp)).AutoFilter Field:=3, Criteria1:="Credit"
ActiveCell.Offset(1, -1).Select
'ActiveCell.Offset(1, 0).Select
'Selection.AutoFilter
End Sub
It is giving the below result:-
But it should be "B5" in this case.
Mainly the changes are to be made in the below code:
ActiveCell.Offset(1, -1).Select
Autofilters can create non-contiguous ranges like $C$1:$C$2,$C$6,$C$11,$C$15,$C$19 which means having multiple areas to deal with.
Sub Macro6()
Dim ws As Worksheet, lastrow As Long
Dim rngFilter As Range, rng As Variant
Set ws = ThisWorkbook.ActiveSheet
ws.Columns("B:B").Insert Shift:=xlToRight
ws.Range("B1").Value = "p"
If ws.AutoFilterMode = True Then ws.AutoFilter.ShowAllData
lastrow = ws.Range("C" & Rows.Count).End(xlUp).Row
Set rngFilter = ws.Range("A1:C" & lastrow)
rngFilter.AutoFilter Field:=3, Criteria1:="credit"
Set rng = Intersect(rngFilter.SpecialCells(xlCellTypeVisible), ws.Columns(3))
If rng.Areas.Count = 1 Then
If rng.Cells.Count = 1 Then
' no cell to select
MsgBox "No cell to select", vbCritical
Else
rng.Offset(1, -1).Select
End If
Else
If rng.Areas(1).Cells.Count > 1 Then
rng.Offset(1, -1).Select
Else
rng.Areas(2).Offset(0, -1).Select
End If
End If
End Sub
I have a VBA code which copies same data from Multiple sheet and then paste it in "Main" Sheet. It then auto fills the blank cells for values from above and then it delete all the rows Where H:H is blank. However being novice in VBA, i feel my code has too many loops, which makes it run slower. Moreover if have the "Main" Sheet have a table formatted, the code does not delete any row H is blank. However it works if "Main" is blank and not formatted.
Another thing I found out that after the code is executed, the excel sheet becomes less responsive. I cannot select cells quickly, change between sheets.
Please advise if anything can be improved to make it run more efficiently.
Private Sub CopyRangeFromMultiWorksheets1()
'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <>
"TECHTeamList" Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng1 = sh.Range("B3")
Set CopyRng2 = sh.Range("C3")
Set CopyRng3 = sh.Range("D3")
Set CopyRng4 = sh.Range("G3")
Set CopyRng5 = sh.Range("C5")
Set CopyRng6 = sh.Range("A8:j25")
Set CopyRng7 = sh.Range("A28:j45")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this
macro
CopyRng1.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng2.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng3.Copy
With DestSh.Cells(Last + 1, "C")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng4.Copy
With DestSh.Cells(Last + 1, "D")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng5.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
'Refresh the Lastrow used so that the values start from
'underneath copyrng6
Last = LastRow(DestSh)
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
'Autofill the rang A2:E for values from above looking at the last row of F
With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Any Help would be appreciated.
I have assembled this code together to copy different ranges from multiple sheets to master sheet. However for copyRng 7, instead of going underneath the copyrng6, it overwrites copyrng6.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
Set DestSh = Sheets("Main")
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "Main" And sh.Name <> "Master" Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng1 = sh.Range("B3")
Set CopyRng2 = sh.Range("C3")
Set CopyRng3 = sh.Range("D3")
Set CopyRng4 = sh.Range("G3")
Set CopyRng5 = sh.Range("C5")
Set CopyRng6 = sh.Range("A8:j25")
Set CopyRng7 = sh.Range("A28:j44")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng1.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng2.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng3.Copy
With DestSh.Cells(Last + 1, "C")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng4.Copy
With DestSh.Cells(Last + 1, "D")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng5.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Thanks in advance. This is my first question I do apologize in advance for any mistake or confusion. I can offer more explanation if asked. Thanks
refresh the last variable between 6 and 7 copy to refresh the new last row on the sheet after 6 is copied:
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
last = LastRow(DestSh)
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
After various trial and errors and helps from this forum, I managed to come out with the following codes to achieve what I want but it's two vba loops. I am hit with bottleneck on how to combine these two vba with loops into 1 single vba.
Here is my code.
Sub Macro1()
'
' Macro1 Macro
'
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Sheets(I).Select
Range("B11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("B11").Select
ActiveCell.FormulaR1C1 = "Outlet name"
Range("C11").Select
ActiveCell.FormulaR1C1 = "PO Number"
Range("D11").Select
ActiveCell.FormulaR1C1 = "PO Date"
Range("E11").Select
ActiveCell.FormulaR1C1 = "Delivery Date"
' Copy outlet name
Range("B1").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy PO number
Range("B2").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy PO date
Range("B3").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 3).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
' Copy DO date
Range("B4").Select
Selection.Copy
Range("A12").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 4).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Select
ActiveSheet.Paste
Next I
Exit Sub
End Sub
Here is the second vba.
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0)
Set CopyRng = CopyRng.Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Thank you for your valuable time to read through this.
Cheers
Without explanation, it's unclear what this code is supposed to do, but I cleaned it up a little bit anyhow.
Create a separate procedure to run these two sub's in whichever order you need them to run. For example:
Sub runMyThings()
Call Macro1
Call Macro2
End Sub
Note that I changed the name of Marco2 to Macro2, but you should probably give them more meaningful names than that. (Otherwise it's like having all your files called File.)
Option Explicit
Sub Macro1()
Dim i As Integer
For i = 1 To ActiveWorkbook.Worksheets.Count
Sheets(i).Range("B11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("B11").FormulaR1C1 = "Outlet name"
Range("C11").FormulaR1C1 = "PO Number"
Range("D11").FormulaR1C1 = "PO Date"
Range("E11").FormulaR1C1 = "Delivery Date"
' Copy outlet name
Range("B1").Copy
Range("A12").End(xlDown).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy PO number
Range("B2").Copy
Range("A12").End(xlDown).Offset(0, 2).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy PO date
Range("B3").Copy
Range("A12").End(xlDown).Offset(0, 3).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
' Copy DO date
Range("B4").Copy
Range("A12").End(xlDown).Offset(0, 4).Select
Range(Selection, Selection.End(xlUp).Offset(1)).Paste
Next i
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Macro2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next 'this will delete the Sheet WITHOUT WARNING.
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0)
Set CopyRng = CopyRng.Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I'm not proud of leaving the code like this but without a better idea of what you're trying to do, I can't do anything more. (And if it doesn't work now, revert to your previous code.)
I attempted to refactor your code some to eliminate most of the select statements and combine various offsets and endup's and enddown's. (You should check that the combined results are still what you expect.)
Sub Macro1()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count 'ThisWorkbook (?)
For I = 1 To WS_Count
with Sheets(I)
.Range(.Range("B11"), .Range("B11").End(xlDown).Offset(0,4)).Insert Shift:=xlToRight
.Range("B11").FormulaR1C1 = "Outlet name"
.Range("C11").FormulaR1C1 = "PO Number"
.Range("D11").FormulaR1C1 = "PO Date"
.Range("E11").FormulaR1C1 = "Delivery Date"
' Copy outlet name
.Range("B1").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 1), .Range("A12").Offset(1, 1).End(xlUp)).Paste
' Copy PO number
.Range("B2").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 2), .Range("A12").Offset(1, 2).End(xlUp)).Paste
' Copy PO date
.Range("B3").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 3), .Range("A12").Offset(1, 3).End(xlUp)).Paste
' Copy DO date
.Range("B4").Copy
.Range(.Range("A12").End(xlDown).Offset(0, 4), .Range("A12").Offset(1, 4).End(xlUp)).Paste
end with
Next I
End Sub
I added some commentary to the following sub as well:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
'If the sheet is always being deleted from the workbook which holds this code, the following line should be:
'ThisWorkbook.Worksheets("RDBMergeSheet").Delete
'That way, if multiple books are open, it won't try to delete from the wrong workbook
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add 'ThisWorkbook (?)
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook (?)
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0).Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next sh 'added sh to be more explicit on which loop this is for
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Answer
I noticed that both subs loop through the worksheets in the workbook, so you should be able to combine the two by taking the code from within one sheet-loop and inserting it into the other, like so:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function
Sub Marco2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
'If the sheet is always being deleted from the workbook which holds this code, the following line should be:
'ThisWorkbook.Worksheets("RDBMergeSheet").Delete
'That way, if multiple books are open, it won't try to delete from the wrong workbook
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add 'ThisWorkbook (?)
DestSh.Name = "RDBMergeSheet"
For Each sh In ActiveWorkbook.Worksheets 'ThisWorkbook (?)
-------------------------------------------------------------
| 'From Macro1
| with sh
| .Range(.Range("B11"), .Range("B11").End(xlDown).Offset(0,4)).Insert Shift:=xlToRight
| .Range("B11").FormulaR1C1 = "Outlet name"
| .Range("C11").FormulaR1C1 = "PO Number"
| .Range("D11").FormulaR1C1 = "PO Date"
| .Range("E11").FormulaR1C1 = "Delivery Date"
|
| ' Copy outlet name
| .Range("B1").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 1), .Range("A12").Offset(1, 1).End(xlUp)).Paste
|
| ' Copy PO number
| .Range("B2").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 2), .Range("A12").Offset(1, 2).End(xlUp)).Paste
|
| ' Copy PO date
| .Range("B3").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 3), .Range("A12").Offset(1, 3).End(xlUp)).Paste
|
| ' Copy DO date
| .Range("B4").Copy
| .Range(.Range("A12").End(xlDown).Offset(0, 4), .Range("A12").Offset(1, 4).End(xlUp)).Paste
| End With
| 'End of from Macro1
----------------------------------------------------------
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
Set CopyRng = sh.Range("A12").Offset(1).CurrentRegion
Set CopyRng = CopyRng.Offset(1, 0).Resize(CopyRng.Rows.Count - 1)
CopyRng.Copy
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next sh 'added sh to be more explicit on which loop this is for
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub
My problem is, when my file is shared with others (share workbook), myself and them can save and everything and add rows, but the thing is the data validation is not copied in the new line and the drop down won't appear.
Anyone can help?
Try this. Your code worked for me so it looks like it might be something related to sharing (as per my comment).
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
With this code of #Captain Grum
Sub InsertRow()
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
It copies now the data validation below, but the borders and formula won't copy.
Please see this picture
I'm really sorry guys. I'm really just new to programming. I now have the solution to my problems. I just have included the code of #captain grumpy and mine above. Here's the code:
Sub InsertRow()
Dim rActive As Range
Set rActive = ActiveCell
Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub