I am working on a macro that will update an excel spreadsheet from another sheets information. But, when updating I want to move two columns to the front because I don't want them to change. Everything works up to the point where I move the two columns to the front. I select them, cut them and paste them but for some reason right after the paste happens it throws an error saying the paste had failed (error 1004-PasteSpecial method of Range class failed). I am very confused on why this is happening and any help would be greatly appreciated.
Sub crossUpdate()
Dim rng1 As Range, rng2 As Range, rng1Row As Range, rng2Row As Range, Key As Range, match As Integer
Dim wb1 As Workbook
Dim wb2 As Workbook
Set wb1 = Workbooks("011 High Level Task List v2.xlsm")
Set wb2 = Workbooks("011 High Level Task List v2 ESI.xlsm")
'Unfilter and Unhide both sheets
With wb1.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
With wb2.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
'Copy and paste original sheet to new temp sheet
wb1.Sheets("Development Priority List").Activate
wb1.Sheets("Development Priority List").Cells.Select
Selection.Copy
Sheets.Add.Name = "SourceData"
wb1.Sheets("SourceData").Paste
'Sort temp sheet by key
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = wb1.Sheets("SourceData").Cells.Range("A2:A" & N)
Set rng1Row = rng1.EntireRow
rng1Row.Sort Key1:=Sheets("SourceData").Range("A1")
'Update sheet sorted by key
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = wb2.Sheets("Development Priority List").Cells.Range("A2:A" & N)
Set rng2Row = rng2.EntireRow
rng2Row.Sort Key1:=wb2.Sheets("Development Priority List").Range("A1")
'Dev columns moved on update sheet
With wb2.Sheets("Development Priority List")
.Columns("F:G").Cut
.Columns("A:B").Insert Shift:=xlToRight
.Activate
.Columns("A:B").Select
End With
Selection.PasteSpecial <------ Line that throws error
End Sub
Change your block of code as such:
With wb2.Sheets("Development Priority List")
.Columns("A:B").Insert Shift:=xlToRight
.Columns("H:I").Cut
.Range("A1").PasteSpecial
End With
Related
I have a master worksheet that contains data with many columns.
Next I have also created multiple worksheets from a list.
Now, I would like to copy the rows from the master worksheet to the respective worksheets if the value in the column matches against all the worksheet name, else copy to an 'NA' sheet.
Previously I could only think of hardcoding, but it is not feasible because the number of worksheets may increase to 50+, so I need some help on how I can achieve this..
'find rows of master sheet
With sh
LstR = .Cells(.Rows.Count, "C").End(xlUp).Row 'find last row of column C
Set rng = .Range("C3:C" & LstR) 'set range to loop
End With
'start the loop
'loop through, then loop through each C cell in template. if cell.value == worksheet name, copy to respective worksheet... elseif... else copy to NA
For Each c In rng.Cells
If c = "WEST" Then
c.EntireRow.Copy wsl1.Cells(wsl1.Rows.Count, "A").End(xlUp).Offset(1) 'copy row to first empty row in WEST
ElseIf c = "PKM" Then
c.EntireRow.Copy wsl2.Cells(wsl2.Rows.Count, "A").End(xlUp).Offset(1)
Else
c.EntireRow.Copy wsl7.Cells(wsl7.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
Thanks to #user9770531, I was able to do what I want for the macro.
However, now I would like to make the macro more flexible.
For example, I have this additional table in another worksheet with
ColA_id and ColB_group
Instead of just matching checking worksheet name against the values in column C, I would like to do this:
if the master file column C matches "ColA_id", copy the data to respective "ColB_group" worksheets. Assuming ColB_group have been used to create the worksheet names.
Use code bellow - all subs in the same (standard) module
It searches Master.ColumnC for each sheet name (except Master and NA)
Uses AutoFilter for each sheet name, and copies all rows at once
All rows not assigned to a specific sheet will be copied to NA
It assumes sheet NA is already created, with Headers
Option Explicit
Const NA_WS As String = "NA" 'Create sheet "NA" if it doesn't exist
Public Sub DistributeData()
Const MASTER_WS As String = "Master"
Const MASTER_COL As String = "C" 'AutoFilter column in Master sheet
Dim wb As Workbook
Set wb = Application.ThisWorkbook
Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
With wb.Worksheets(MASTER_WS)
lr = .Cells(.Rows.Count, MASTER_COL).End(xlUp).Row
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))
Set fCol = .Range(.Cells(2, MASTER_COL), .Cells(lr, MASTER_COL))
Set done = .Range(.Cells(1, MASTER_COL), .Cells(2, MASTER_COL))
End With
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If ws.Name <> MASTER_WS And ws.Name <> NA_WS Then
fCol.AutoFilter Field:=1, Criteria1:=ws.Name
If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
UpdateWs ws, ur
Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
End If
End If
Next
If wb.Worksheets(MASTER_WS).AutoFilterMode Then
fCol.AutoFilter
UpdateNA done, ur
End If
Application.ScreenUpdating = True
End Sub
Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
fromRng.Copy
With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
.PasteSpecial xlPasteAll
End With
ws.Activate
ws.Cells(1).Select
End Sub
Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
done.EntireRow.Hidden = True
If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
End If
done.EntireRow.Hidden = False
Application.CutCopyMode = False
ur.Parent.Activate
End Sub
I've been working on a VBA macro to copy data that matches certain criteria from one worksheet to another worksheet without altering the original worksheet.
I'm locating the last row from worksheet "Prospects" and selecting the criteria that I need and it copies over to the other worksheet "Results", but both worksheets look identical.
So any rows that don't meet the filter criteria are removed from the original worksheet "Prospects".
I need the original worksheet to remain unaltered. I'm also just capturing certain columns, thus hiding the columns that I don't need on the "Results" worksheet.
Sub ProspectList()
Dim r As Range
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Range("A1").AutoFilter
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlUp).Column
With Sheets("Prospect List").Range([A2], [A2].SpecialCells(xlCellTypeLastCell))
ws.Range("A1").AutoFilter field:=13, Criteria1:="Pipeline"
[B:B].EntireColumn.Hidden = True
.Copy
[C:C].EntireColumn.Hidden = True
.Copy
[E:E].EntireColumn.Hidden = True
.Copy
[H:H].EntireColumn.Hidden = True
.Copy
[I:I].EntireColumn.Hidden = True
.Copy
[K:K].EntireColumn.Hidden = True
.Copy
[L:L].EntireColumn.Hidden = True
.Copy
[B:B].EntireColumn.Hidden = False
[C:C].EntireColumn.Hidden = False
[E:E].EntireColumn.Hidden = False
[H:H].EntireColumn.Hidden = False
[I:I].EntireColumn.Hidden = False
[K:K].EntireColumn.Hidden = False
[L:L].EntireColumn.Hidden = False
End With
With Sheets("Results")
If .Cells(Sheets(1).Rows.Count, 1).End(xlUp) = "" Then 'it's a clean sheet
.Cells(Sheets(1).Rows.Count, 1).End(xlUp).PasteSpecial Paste:=xlPasteValues
Else
.Cells(Sheets(1).Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
End With
Application.CutCopyMode = False
End Sub
First: Your title is confusing; do you want to filter the data on worksheet "Prospects", copy the visible data, and move it to the "Results" worksheet?
Second: you "Dim r As Range" but you don't use it in your code.
Third: you Don't Dim "LastRow" and "LastCol" and don't even use them in your code.
Forth: Why are you filter "column A" then "filter Column M" before you hide the specific columns and u-nhide them?
Fifth: your "LastCol" code is wrong
Six: You hide and un-hide the columns for no apparent reason.
Seventh: your "With code" does not make any sense, you are testing "sheet1", not copying anything and then pasting on "sheet1" not the "Results" sheet. which worksheet is "Sheets(1)"?
I would suggest that you filter your data on the "Prospects" worksheet select the visible data using .SpecialCells(xlCellTypeVisible).Copy then paste to the "Results" worksheet
This is what I ended up doing.
Sub ProspectList()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ActiveSheet
'Find last row and copy complete sheet to new sheet
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
Sheets("Prospects").Range("A1:M" & LastRow).Copy Destination:=Sheets("Results").Range("A1")
'set the new "Results" sheet to active
Worksheets("Results").Activate
'filter by criteria and hide columns not needed
With Sheets("Results")
ws.Range("A1").AutoFilter Field:=13, Criteria1:="Pipeline"
[B:B].EntireColumn.Hidden = True
[C:C].EntireColumn.Hidden = True
[E:E].EntireColumn.Hidden = True
[H:H].EntireColumn.Hidden = True
[I:I].EntireColumn.Hidden = True
[K:K].EntireColumn.Hidden = True
[L:L].EntireColumn.Hidden = True
[M:M].EntireColumn.Hidden = True
End With
Application.CutCopyMode = False
End Sub
I'm using this macro to copy columns A and B from all of my sheets into a new sheet named Master. What I notice is that entire sheets worth of information are missing in the master sheet and I can't figure out why. The format for my sheets is column A has a string of characters that follow this structure: M2,004,005,004,007,17,096,01:07:45,45 and column B is just a date such as 4/19/2017.
I have hundreds of these sheets in my workbook and each has 224 rows that I need to copy into a single master sheet. Could anyone help me figure out how to get this code to stop skipping sheets?
Thanks.
Sub CreateMaster()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Master"
Sheets(2).Activate
Range("A1:B1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1:B1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1:B1").Select
Selection.CurrentRegion.Select
Selection.Copy Destination:=Sheets(1).Range("A65536:B65536").End(xlUp)(2)
Next
End Sub
while searching for solutions online, I came across this macro that seems to do the same thing, but also seems to skip the exact same sheets as my macro does.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object
variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
as a workaround, since only the most recent data is immediately pertinent, I worked around it, but deleting the first 150 sheets. that still left around 100 sheets for my macro to work on, but now the missing pieces of data seem to be there. I wonder if there's something about the quantity of sheets that is causing this to malfunction?
Comments may not get it across correctly. Restructure your loop (and add the variables mentioned).
Dim x as Long
Dim thisSht as Worksheet
For x = 1 to wrk.Worksheets.Count
set thisSht = wrk.Worksheets(x)
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = thisSht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next x
Could someone please help with my code, I am not a million miles away from what I am looking to do but I have now come unstuck and reached a dead end. I have no programming experience & am no expert with VBA so what I have done might not make sense, or look silly; please bear with me as I am learning.
What I want to do is be able to:
Filter Column H in sheet “master” to select dates before a date
which I will input in Range “B9”.
Delete the filtered lines
Go to sheet “update”
Copy from A:18 dynamically to last column & last row
Paste everything in the last row in sheet “master”
Problem I have is that the filter for the date is not working
Sub AUTODATE()
Dim dDate As Date
Dim dbDate As Double
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate) + 1)
Application.ScreenUpdating = False
Sheets("master").Select
If IsDate(Range("B9")) Then
dbDate = Range("B9")
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate)) + _
TimeSerial(Hour(dbDate), Minute(dbDate), Second(dbDate))
Range("H11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
Range("$11:$11").AutoFilter Field:=8, Criteria1:=">" & dbDate
Range("$12:12").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells _
(xlCellTypeVisible).EntireRow.Delete
Range("A11").Select
On Error Resume Next
ActiveSheet.ShowAllData
Sheets("update").Select
ActiveSheet.ShowAllData
Range("$18:$18").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("master").Select
Range("A" & lastRow).Select
Selection.PasteSpecial
End If
Application.ScreenUpdating = False
End Sub
The codes a bit messy near the bottom, and some thing's I'd normally push out to a separate function (find last cell for example).
Sub AutoDate()
Dim lastRow As Long
Dim lastUpdateRow As Long
Dim wrksht As Worksheet
Dim rFilterRange As Range
Set wrksht = ThisWorkbook.Worksheets("master")
'Any statement that starts with a '.' applies to wrksht (With... End With)
With wrksht
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'The range to be filtered - currently columns A:J (columns 1 - 10)
Set rFilterRange = .Range(.Cells(11, 1), .Cells(lastRow, 10))
'Turn off the autofilter if it's already on.
If .AutoFilterMode Then
wrksht.AutoFilterMode = False
End If
'Apply filter to correct range.
rFilterRange.AutoFilter
If IsDate(.Range("B9")) Then
'Apply filter.
rFilterRange.AutoFilter Field:=8, Criteria1:=">" & .Range("B9")
If .FilterMode Then
'Resize to ignore header row & delete visible rows.
rFilterRange.Offset(1).Resize(rFilterRange.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
.ShowAllData
End If
'Find new last row.
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set rFilterRange = .Range(.Cells(11, 1), .Cells(lastRow, 10))
lastUpdateRow = ThisWorkbook.Worksheets("Update").Cells(Rows.Count, "A").End(xlUp).Row
rFilterRange.Offset(1).Resize(rFilterRange.Rows.Count - 1).Copy _
Destination:=ThisWorkbook.Worksheets("Update").Cells(lastUpdateRow, 1)
End If
End With
End Sub
Requirements:
Filter Column H in sheet master to select dates before a date located in same sheet at B9
Delete filtered lines
Copy from sheet update range A:18 dynamically to last column & last row
Paste range from previous point in the last row + 1 of sheet master
Assumptions: (in line with code posted):
Data range in sheet master starts at A11 and all cells in columns 8 of the data range have same NumberFormat
Data range in sheet update starts at A18
Data ranges in both sheets are continuous (i.e. no blank rows nor blank columns in between)
Copy of the data includes formulas & formats
Thy this code:
Option Explicit
Sub Rng_AutoFilter_Delete_And_Paste()
Dim WshMaster As Worksheet, WshUpdate As Worksheet
Dim rMaster As Range, rUpdate As Range
Dim dDate As Date
Dim rTmp As Range
Rem Application Settings - OFF
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Rem Set Worksheet Object - End Procedure If any of them is not present
With ThisWorkbook
On Error GoTo ExitTkn
Set WshMaster = .Sheets("master")
Set WshUpdate = .Sheets("update")
On Error GoTo 0
End With
If IsDate(WshMaster.Range("B9")) Then
Rem Cleared Records in Wsh Master
With WshMaster
Rem Set Date to Filter By
dDate = .Range("B9")
Rem Set Data Ramge in Wsh Master
'Assumes range start at `A11` and it's continuous (i.e. no blank rows nor blank columns in between)
Set rMaster = .Range("A11").CurrentRegion
Rem Set AutoFilter
'Use the `AutoFilter` property instead of the `AutoFilterMode` property
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
rMaster.AutoFilter
End With
With rMaster
Rem Filter and Delete Records in Wsh Master
'Uses the `NumberFormat` to build the Filter Criteria
'Assumes all cells in has same `NumberFormat`
.AutoFilter Field:=8, Criteria1:=">" & Format(dDate, .Cells(2, 8).NumberFormat)
'Sets a Temp Range to grab the Filter results
On Error Resume Next
Set rTmp = .Offset(1).Resize(-1 + .Rows.Count).Columns(8).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'If Temp Range is `Nothing` then there is `Nothing` to delete
If Not (rTmp Is Nothing) Then rTmp.EntireRow.Delete
.Worksheet.ShowAllData
End With
Rem Set Data Range in Wsh Update
With WshUpdate
Rem Set Data Range in Wsh Update
'Assumes range start at `A18` and it's continuous (i.e. no blank rows nor blank columns in between)
Set rUpdate = .Range("A18").CurrentRegion
Rem Set AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
rUpdate.AutoFilter
End With
Rem Paste Records from Wsh Update into Wsh Master
rUpdate.Copy
'In line with code posted this assumes OP wants to copy the data as it is (i.e. including formulas & format)
rMaster.Offset(rMaster.Rows.Count).Resize(1, 1).PasteSpecial
Application.CutCopyMode = False
Application.Goto WshMaster.Cells(1), 1
End If
ExitTkn:
Rem Application Settings - ON
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Excel Objects, On Error Statement, Range Object (Excel), Variables & Constants,
Worksheet.AutoFilter Property (Excel), Worksheet.AutoFilterMode Property (Excel),
Worksheet Object (Excel), With Statement
I have also done a review of your code see below (including only lines with comments):
'lastRow variable is not declared.
'Suggest to always have Option Explicit at the begining of the module
'To do it goto Main Menu \ Options \ Tab: Editor \ Check: Require Variable Declaration
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 'This is done too early as it will change after deletion of filtered rows
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate) + 1) 'Have no purpose as no value have been assigned to the variable as yet
Application.ScreenUpdating = False 'this should be done at the beginning
Sheets("master").Select 'should be qualified
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate)) + _
TimeSerial(Hour(dbDate), Minute(dbDate), Second(dbDate)) 'This line achieves nothing.
Range("H11").Select 'Select should be avoided, instead work with objects
Selection.AutoFilter 'Sould check first is the AutoFilter is ON
Range("$11:$11").AutoFilter Field:=8, Criteria1:=">" & dbDate 'Should filter the entire range
On Error Resume Next 'On error should be used for specific purposes and cleared after with On Error Goto 0
Selection.PasteSpecial 'After paste the Clipboard must be cleared with Application.CutCopyMode = False
Im designing a macro that will take two sheets, an original and one to be updated from the original. It takes the original and copies the sheet and sorts everything by a key. It also unhides and unfilters the data so that all the keys are in order. All of this works except the sheet to be updated does not become unfiltered and I can't see why. Any help would be greatly appreciated.
Sub crossUpdate()
Dim rng1 As Range, rng2 As Range, rng1Row As Range, rng2Row As Range, Key As Range, match As Integer
Workbooks("011 High Level Task List v2.xlsm").Activate
'Unhide and Unfilter columns and rows on original sheet
Sheet3.Cells.EntireColumn.Hidden = False
Sheet3.Cells.EntireRow.Hidden = False
Sheet3.Cells.AutoFilter
'Copy and paste original sheet to new temp sheet
Sheet3.Cells.Select
Selection.Copy
Sheets.Add.Name = "SourceData"
ActiveSheet.Paste
'Sort temp sheet by key
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Sheets("SourceData").Cells.Range("A2:A" & N)
Set rng1Row = rng1.EntireRow
rng1Row.Sort Key1:=Sheets("SourceData").Range("A1")
Workbooks("011 High Level Task List v2 ESI.xlsm").Activate
'Unhide and Unfilter columns and rows on update sheet
Sheet3.Cells.EntireColumn.Hidden = False
Sheet3.Cells.EntireRow.Hidden = False
Sheet3.AutoFilterMode = False
'Update sheet sorted by key
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = Sheets("Sheet3").Cells.Range("A2:A" & N)
Set rng2Row = rng2.EntireRow
rng2Row.Sort Key1:=Sheets("Sheet3").Range("A1")
End Sub