PasteSpecial function doesn't work in excel - excel

I need to make a macro that paste data, when i record the macro i have the same problem every time. I hope someone can help me with my problem.
Every time i debug i get the same problem with this function:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("AP5:AP43").Select
Selection.Clear
Range("AP5").Select
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=4, Criteria1:="IT"
Range("C5:C51").Select
Selection.Copy
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=4
Range("AP5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("Table9[#All]").RemoveDuplicates Columns:=1, Header:= _
xlYes
Range("Table9[Forecast på aktiviteter]").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("AS29").Select
End Sub

Related

I want to compare e remove duplicates of copied values in VBA

I have a question about the macro that I am running. I want to copy / paste the values cross sheet, but the target sheet I want to compare the values and remove duplicates of intercalated columns.
So, the copy and paste is working well, but to comparing and removing duplicates is not working.
Is there something else that I should try in my Macro?
Sub GetInformation()
'
' Macro2 Macro
'
'some comments
Sheets("SpExtra").Select
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRToday").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("5lbExt").Select
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRInformationToday").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("20LBExtra").Select
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRToday").Select
Range("G1").Select
ActiveSheet.Paste
Sheets("JRExtra").Select
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRToday").Select
Range("J1").Select
ActiveSheet.Paste
Sheets("SExtra").Select
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRToday").Select
Range("M1").Select
ActiveSheet.Paste
'some comments
Sheets("CRToday").Select
Range("J2:J4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("J3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRToday").Select
Range("A2:A12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("N3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRToday").Select
Range("M2:M4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("R3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRToday").Select
Range("D2:D14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("V3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRToday").Select
Range("D15:D27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("V17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRToday").Select
Range("G2:G10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CRSts").Select
Range("Z3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(10, 14, 18, 22, 26), Header _
:=xlYes
End Sub

VBA Autofilter Sheet Name

When applying the macro auto filter, we would like to make it work on the sheet we are currently working on regardless of the sheet.
ActiveWorkBook.Worksheets("sheetname").Sheet.AutoFilter.Sort.SortFields.Clear
-> I changed to
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
but it does not work.
Sub Name()
Application.ScreenUpdating = False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Replace What:="#N/A", Replacement:="#N/A", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
ActiveSheet.AutoFilter.Sort.SortFields.Add(Range( _
"F1:F2000"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB( _
255, 255, 0)
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=6, Criteria1:=RGB(255, _
255, 0), Operator:=xlFilterCellColor
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("T2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T2").Select
Application.CutCopyMode = False
ActiveWorkSheet.Range("$A$1:$S$2000").AutoFilter Field:=6
Application.CutCopyMode = False
ActiveSheet.AutoFilter.Sort.SortFields.CLEAR
ActiveSheet.AutoFilter.Sort.SortFields.Add(Range( _
"L1:L2000"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
= RGB(255, 255, 0)
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=12, Criteria1:=RGB(255, _
255, 0), Operator:=xlFilterCellColor
Range("I2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("U2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("U2").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$S$2000").AutoFilter Field:=12
Columns("T:U").Select
Application.ReplaceFormat.CLEAR
With Application.ReplaceFormat.Font
.Subscript = False
.TintAndShade = 0
End With
With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Replace What:="_1", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("M2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(C[7]:C[8],RC[-11])"
Range("M2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Try this:
Dim Nome_Planilha As String
Nome_Planilha = ActiveSheet.Name
ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort.SortFields.Add Key:= _
Range("A1:A872"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets(Nome_Planilha).AutoFilter.Sort
.Orientation = xlTopToBottom
.Apply
End With

Why can I not reference a sheet name all of a sudden after over a year of running this Macro?

'-2147319767 (80028029)':
Been using this code for over a year now. Suddenly today, it gets the above run-time error when calling out certain sheet names or calling out Activesheet.
Absolutely no idea why it decided not to function today.
'''
Sheets("WIP Shortage").Select
Range("A:CB").Select
Selection.Delete Shift:=xlUp
Range("CC1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC1").Select
Selection.NumberFormat = "yyyy m-d;#"
ChDir "S:\Skim Kits\WIP Shortage Report"
Workbooks.Open Filename:= _
"S:\Skim Kits\WIP Shortage Report\" & Range("CC1").Text & " GEUD_WIP_Job_Shortage_Shop_Fl_ELO.xlsx"
Range("CC1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC1").Select
Selection.NumberFormat = "yyyy m-d;#"
Range("CC2").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("CC2").Select
Selection.NumberFormat = "yyyy-m-d;#"
Cells.Select
Selection.Copy
Windows("Availability-Shortages" & Range("CC2").Text).Activate
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("CD2").Select
ActiveCell.FormulaR1C1 = "=ISOWEEKNUM(RC[-76])"
Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown))
Windows(Range("CC1").Text & " GEUD_WIP_Job_Shortage_Shop_Fl_ELO.xlsx").Activate
ActiveWindow.Close
' Paste Thiswk Lastwk formula as values on QMI Targets
Application.Calculation = xlManual
Sheets("WIP Shortage").Select
Range("CE2").Select
ActiveCell.Formula = "=CD2+1"
Application.Calculation = xlAutomatic
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.Calculation = xlManual
Sheets("QMI TARGETS").Select
Range("AL2").Select
ActiveCell.Formula = "=SUMIFS('WIP Shortage'!L:L,'WIP Shortage'!K:K,A2,'WIP Shortage'!E:E,""OP"",'WIP Shortage'!CD:CD,ISOWEEKNUM(NOW()))"
Selection.Copy
Range("AL2:AL300").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.Calculation = xlAutomatic
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.Calculation = xlManual
Range("AM2").Select
ActiveCell.Formula = "=SUMIFS('WIP Shortage'!L:L,'WIP Shortage'!K:K,A2,'WIP Shortage'!E:E,""OP"",'WIP Shortage'!CE:CE,ISOWEEKNUM(NOW()))"
Selection.Copy
Range("AM2:AM300").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.Calculation = xlAutomatic
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'''
This is an excerpt from the entire code, but that first line is the first of 4 places it faults out. If I debug and manual select the sheet and move down the to the next line and run, it goes fine until I try to call out active sheet on line 23.
This is the code that precedes it and it runs fine. You'll notice it calls out my "today" sheet just fine and even renames it.
'''
Sheets("Today").Select
If Range("C5") = "Fri" Then
Sheets("Fri").Select
If Range("C5") = "Fri" Then
Sheets("Fri").Select
ActiveWindow.SelectedSheets.Delete
End If
End If
'''

How to write code to check if a column contains a value, then put a specified value in another cell

Ok so I have a timesheet spreadsheet that I use and I've added some code to it (a while back now) to summarise my arrival and leaving times for the week. I'm now trying to update it so that it looks for a certain value within a column ("9df"), and if it contains it the put "9df" instead of the time.
This is what I currently have, I tried the commented bit on the end but it doesn't work. Thinking I'm going to have to do an If Else? Just can't get my head around it yet so any help would be appreciated:
Sub LeaveArriveTime()
Sheets("Time Log").Select
Range("B58").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -1).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("D58").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -3).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("F58").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -5).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("H58").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -7).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("J58").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, -9).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("B1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("D1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -3).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("F1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -5).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("H1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -7).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
Sheets("Time Log").Select
Range("J1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -9).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("StartEnd Times").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm"
' If Sheets("Time Log").Range("B2:B58").Value = "9df" Then
' Sheets("StartEnd Times").Range("B2:B3").Value = "9df"
' End If
End Sub
Thanks in advance!
Ok I solved it by changing the way I use the sheet. By always starting the 9df at a time I never start work at, I can now search a cell for that time and amend it to 9df if it's found. Using this:
Sub Monday9df()
Sheets("Time Log").Range("B3").Select
ActiveCell.FormulaR1C1 = "9df"
Selection.AutoFill Destination:=Range("B3:B18"), Type:=xlFillCopy
End Sub

Short way of doing this in Excel. Transferring data to another sheet, then clearing cells and saving

I want to transfer data that is in one column (D4:D21 on sheet 'dispersed') to the next empty row in another sheet (B$:N$ on 'sheet4'). Also in the A column on sheet4, I want the date that is in 'dispersed'!b4 I then want the original cells cleared (so that it can be filled out again in a month) and the workbook saved.
I recorded a macro to do this but it is very long. I also can't work out how to change it so that it fills the data on the next empty row as when I recorded the macro it lists the specific cells to paste to.
The end result in 'sheet4' should give me a running total of amounts paid.
Here is the macro that I recorded.
Sub Transfer_dispersments()
'
' Transfer_dispersments Macro
' Botton to transfer data from dispersment to totals
'
'
Range("D4").Select
Selection.Copy
Sheets("Sheet4").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("L2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Dispersed").Select
Range("D4:D18").Select
Range("D18").Activate
Application.CutCopyMode = False
Selection.ClearContents
Range("B4").Select
Selection.Copy
Sheets("Sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Dispersed").Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveWorkbook.Save
End Sub
There are many ways of determining the "last row" of a worksheet. I used one method in the below code:
Sub Transfer_dispersments()
'
' Transfer_dispersments Macro
' Botton to transfer data from dispersment to totals
'
Dim newRow As Long
'Find last non-empty cell in column B
'(and then add 1 so that we point to the row we want to write to)
newRow = Sheets("Sheet4").Cells(Sheets("Sheet4").Rows.Count, "B").End(xlUp).Row + 1
'Copy values from D4:D18 on Dispersed sheet
' to Bx:Px on Sheet4 sheet
Sheets("Sheet4").Cells(newRow, "B").Resize(1, 15).Value = Application.Transpose(Sheets("Dispersed").Range("D4:D18").Value)
'Copy cell from B4 on Dispersed sheet
' to Ax on Sheet4 sheet
Sheets("Dispersed").Range("B4").Copy Sheets("Sheet4").Cells(newRow, "A")
'Clear contents of copied cells
Sheets("Dispersed").Range("D4:D18").ClearContents
Sheets("Dispersed").Range("B4").ClearContents
'Save workbook
ActiveWorkbook.Save
End Sub

Resources