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
Related
Apologies if this has been answered before, I'm unable to find anything that matches my specific case.
I have a workbook with 18 sheets, and a variable number of columns per sheet starting at B2. Occasionally the program that generates the sheet will create duplicate columns, due to this, I need a macro triggered by button to search each sheet for matching column headers and then delete one of these columns (the whole column, not just the header).
So far I'm pretty stuck, I've been able to delete all matches from any cell in the sheet, which pretty much wipes the entire sheet out. I just need to match headers and then delete the entire column based on that.
Let me know if you need any more information, and thank you for the help!
What I have so far, the code is doing some other stuff too so this needs to continue working.
Sub RemoveExtras()
Dim MyRange As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
BadCharacters = Array(Chr(10), Chr(13))
wsNumber = Sheets.Count
For Each ws In Worksheets
With ws
For Each MyRange In .UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
For Each i In BadCharacters
MyRange = Replace(MyRange, i, vbNullString)
Next i
End If
For t = 1 To wsNumber
Columns(t).RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next t
Next MyRange
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Dictionaries are perfect for handling unique values:
Sub RemoveExtras()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Integer, i As Integer, ws As Worksheet
Dim dict As Object
For Each ws In Worksheets
Set dict = CreateObject("Scripting.Dictionary")
'Find Last column
c = ws.UsedRange.Columns.Count
'Loop backwards
For i = c To 2 Step -1
'If column does not exist in dictionary, then add it
If Not dict.Exists(ws.Cells(2, i).Value) Then
dict.Add ws.Cells(2, i).Value, 1
Else
'Otherwise delete column
ws.Columns(i).Delete Shift:=xlToLeft
End If
Next i
Set dict = Nothing
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Here you do not compare every pair of column headers in the sheet. Also this compares headers across all the worksheets, not just duplicates inside one individual sheet.
See if this helps you
Sub test()
Dim book As Workbook, sheet As Worksheet, text As String
For Each sheet In Worksheets
Set MR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell In MR
Set BR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell2 In BR
If cell.Value = cell2.Value Then cell.EntireColumn.Delete
Next
Next
Next sheet
End Sub
I have a problem, but my VBA is novice and can't figure out what's going wrong with my code.
What I'm trying to achieve is:
Step 1. In Sheet 1 I have lots of data beneath the headings in cells B8:BR8
Step 2. I filter on cell BE8 for non-blanks
Step 3. I copy the filtered data beneath BE8:BN8 (excluding the headings and I don't need all of the data hence I'm just copying a subset of the full data)
Step 4. I go to Sheet 2 where I have a populated table with headings in C8:L8 that correspond exactly to the headings BE8:BN8 from Sheet 1
Step 5. I want to append this new copied set of data to the end of this table in Sheet 2
Step 6. I want to go back to Sheet 1 and delete some of the filtered data, specifically those under headings BE8,BK8:BN8
Here's my attempt which I've tried to adapt from another code:
Sub TransferData()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim RngBeforeFilter As Range, RngAfterFilter As Range
Dim LCol As Long, LRow As Long
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
With WS1
'Make sure no other filters are active.
.AutoFilterMode = False
'Get the correct boundaries.
LRow = .Range("BE" & .Rows.Count).End(xlUp).Row
LCol = .Range("BE8:BN8").Column
'Set the range to filter.
Set RngBeforeFilter = .Range(.Cells(1, 2), .Cells(LRow, LCol)).Offset(1)
RngBeforeFilter.Rows(8).AutoFilter Field:=56, Criteria1:="<>"
'Set the new range, but use visible cells only.
Set RngAfterFilter = .Range(.Cells(1, 7), .Cells(LRow, LCol)).SpecialCells(xlCellTypeVisible)
'Copy the visible cells from the new range.
RngAfterFilter.Copy WS2.Range("C65536").End(xlUp)
'Clear filtered data (not working)
Sheets("Sheet1").Range("B8", Range("B8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.ShowAllData
End With
End Sub
I would appreciate any help that you could provide.
Thanks
Jacque
A few problems here:
.Range("BE8:BN8").Column
probably isn't doing what you expect - it will just return the column number of BE (ie 57).
RngBeforeFilter is doing nothing - you can just use
.Rows(8).AutoFilter Field:=56, Criteria1:="<>"
You say you want to copy data in BE:BN, but you start RngAfterFilter from column A (ie .Cells(1, 7)).
WS2.Range("C65536").End(xlUp)
gives the last row used, whereas you'll want to paste into the next row down.
You're clearing column B, rather than columns BE, BK and BN.
As such, try this instead:
Sub TransferData()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim RngBeforeFilter As Range, RngAfterFilter As Range
Dim BECol As Long, BNCol As Long, LRow As Long
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
With WS1
'Make sure no other filters are active.
.AutoFilterMode = False
'Get the correct boundaries.
LRow = .Range("BE" & .Rows.Count).End(xlUp).Row
BECol = .Range("BE8").Column
BNCol = .Range("BN8").Column
'Set the range to filter.
.Rows(8).AutoFilter Field:=BECol - 1, Criteria1:="<>"
'Set the new range, but use visible cells only.
Set RngAfterFilter = .Range(.Cells(9, BECol), .Cells(LRow, BNCol)).SpecialCells(xlCellTypeVisible)
'Copy the visible cells from the new range.
RngAfterFilter.Copy WS2.Range("C65536").End(xlUp).Offset(1)
'Clear filtered data
.Range("BE9", Range("BE8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.Range("BK9", Range("BK8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.Range("BN9", Range("BN8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.ShowAllData
End With
End Sub
I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub
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
I need to create a macro that will duplicate all the rows of a table when a certain column is true.
I recorded a macro and it gave me this:
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= "TRUE"
Range("Table1").Select
Application.CutCopyMode = False
Selection.Copy
Range("A22").Select 'To be replaced with a method that finds the last cell.
'Selection.End(xlDown).Select gives me the last row in the table, but I want the one under that.
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=12
However before I delve into it I would like to know what would be the best/fastest approach?
Something like this would work. Modify as needed
Sub david()
Application.CutCopyMode = True
Dim lastrow As Integer
Dim rCell As Range
lastrow = ActiveSheet.ListObjects("Table1").ListRows.Count
For Each rCell In ActiveSheet.ListObjects("Table1").ListColumns(2).DataBodyRange
If rCell.Value = "True" Then
ActiveSheet.ListObjects("Table1").ListRows.Add
rCell.EntireRow.Copy
ActiveSheet.ListObjects("Table1").ListRows(lastrow + 1).Range.PasteSpecial Paste:=xlPasteValues
lastrow = lastrow + 1
End If
Next
Application.CutCopyMode = False
End Sub
If you have other data on the same row in the table's sheet, you might need to copy a specific range rather than .entirerow as it will pick up data outside the table.
These two SO threads may help if you want to clean it up some- Copy and Paste Table Row and Add row.
I ended up writing this, much faster. There's some logic which avoids copying the first column (which is a Row() formula. You can probably do without it).
Sub DuplicateRows(tableToDuplicate As String, columnToDetermineIfRowNeedsDuplication As Integer)
Application.DisplayAlerts = False
'Excel is more efficient when copying whole ranges at once rather than row by row.
Dim sourceRange As Range, destRange As Range
Dim rowsToDelete As Range
Set sourceRange = Range(tableToDuplicate)
'Copy source range except row num. Start at bottom of source range. Start at offset x + so that row number is not copied.
Set sourceRange = sourceRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count - 1)
Set sourceRange = sourceRange.Offset(0, 1) ' We don't need to copy the first column.
Set destRange = sourceRange.Offset(sourceRange.Rows.Count, 0)
destRange.Value = sourceRange.Value 'Duplicate all values.
Set rowsToDelete = destRange 'Get complete table now, unfiltered.
rowsToDelete.AutoFilter columnToDetermineIfRowNeedsDuplication, Criteria1:="=FALSE" ' Find which ones we must delete.
Set rowsToDelete = rowsToDelete.Offset(0, -1)
Set rowsToDelete = rowsToDelete.Resize(rowsToDelete.Rows.Count, rowsToDelete.Columns.Count + 1)
rowsToDelete.Rows.Delete
End Sub