VBA - Manipulate Specific Sheet Data With Macro - Not Activesheet - vba

I have 10 sheets in a workbook - These sheets were imported from individual workbooks - These workbooks were extracts from different monitoring tools
I need to apply a filter across all 10 worksheets, however, not all the sheets are in the same format/structure.
With 6 of the worksheets, the column headers are the same and in the same order.
The remaining 4 sheets have different headers. For example: The filter needs to look for a header name Status - This works for the 6 sheets that have the same structure, however, the other 4 sheets have the following:
wsheet1:
User Status instead of Status - I need to change the header to Status
wsheet2:
Current_Status instead of Status - I need to change the header to Status
Below is sample code that is supposed to manipulate the specified sheet in in order to have it "look" the same as the others, however, I am having some really annoying issues where the code isn't applied to the sheet specified and is instead applied to the "Activesheet" when the macro is executed.
Here is the code I have:
Sub arrangeSheets()
Dim lastCol As Long, idCount As Long, nameCount As Long, headerRow As Long
Dim worksh As Integer, WS_Count As Integer, i As Integer, count As Integer
Dim rng As Range, cel As Range, rngData As Range
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
headerRow = 1 'row number with headers
lastCol = Cells(headerRow, Columns.count).End(xlToLeft).Column 'last column in header row
idCount = 1
nameCount = 1
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.count
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
For x = 1 To worksh
If Worksheets(x).Name = "wsheet1" Then
worksheetexists = True
Set rng = Sheets("wsheet1").Range(Cells(headerRow, 1), Cells(headerRow, lastCol)) 'header range
With Worksheets("wsheet1").Name
Rows(2).Delete
Rows(1).Delete
count = Application.Match("*USER STATUS*", Worksheets("wsheet1").Range("A1:AZ1"), 0)
If Not IsError(count) Then
For Each cel In rng 'loop through each cell in header
If cel = "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With
Exit For
End If
Next x
End Sub

Consider using ., in the With-End with section to refer to the Worksheet mentioned:
The Like in If cel Like "*USER STATUS*" works with the *, thus will be evaluated to True for 12USER STATUS12 or anything similar.
The count variable should be declared as variant, thus it can keep "errors" in itself.
This is how the code could look like:
With Worksheets("wsheet1")
.Rows(2).Delete
.Rows(1).Delete
Count = Application.Match("*USER STATUS*", .Range("A1:AZ1"), 0)
If Not IsError(Count) Then
For Each cel In Rng 'loop through each cell in header
If cel Like "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With

If you want the same headers across all sheets in the workbook you could just copy the headers from the first sheet and paste them on each sheet.
This wouldn't work if your column order is different across sheets, but from the example you gave it's just renaming columns rather than re-ordering?
Sub CorrectHeaders()
Dim cpyRng As Range
With ThisWorkbook
If .Worksheets.count > 1 Then
With .Worksheets(1)
Set cpyRng = .Range(.Cells(1, 1), .Cells(1, .Columns.count).End(xlToLeft))
End With
.Sheets.FillAcrossSheets cpyRng
End If
End With
End Sub
If the column headers are in different orders, but you just want to replace any cell that contains the text "Status" with just "Status" then you could use Replace. You may want to add an extra condition of MatchCase:=True.
Sub Correct_Status()
Dim wrkSht As Worksheet
For Each wrkSht In ThisWorkbook.Worksheets
wrkSht.Cells(1, 1).EntireRow.Replace What:="*Status*", Replacement:="Status", LookAt:=xlWhole
Next wrkSht
End Sub

I have additional solution which has also helped with this issue. Code below:
Sub ManipulateSheets()
Dim worksh As Integer
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
Worksheets("wSheet1").Activate
With Worksheets("wSheet1")
.Rows(2).Delete
.Rows(1).Delete
End With
Worksheets("wSheet2").Activate
With Worksheets("wSheet2")
.Rows(2).Delete
End With
End Sub

Related

How to lock entire rows based on a certain word in a column without using Table in dataset

I am aiming to lock entire rows where the word "Done" appears in a specific column. My code below achieves what I seek but it takes 18 seconds to compute (too long). Is there a faster/more efficient coding alternative?
There is an existing question on StackOverflow similar to this (found here) but my data does not exist in defined tables (this won't change), so I don't know how to adapt the suggestion there.
Private Sub Lock_Rows(ByVal Target As Range)
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'finds the last row with data on B column, B column has dates
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
'parse all rows
For i = 26 To lastrow 'rows of data begin at row 26
'if your conditions are met
If .Cells(i, "Z").Value = "Done" Then
.Cells(i, "Z").EntireRow.Cells.Locked = True 'lock the row
Else
.Cells(i, "Z").EntireRow.Cells.Locked = False 'leave rows unlocked
End If
Next i
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
End Sub
The Lock / Unlock operations om individual rows are quite slow. Better to build a range reference to Lock / Unlock and do that operation in on go at the end.
Something like
Private Sub Lock_Rows(ByVal Target As Range)
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Dim rLock As Range, rUnlock As Range
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'finds the last row with data on B column, B column has dates
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
'parse all rows
For i = 26 To lastrow 'rows of data begin at row 26
'if your conditions are met
If .Cells(i, "Z").Value = "Done" Then
If rLock Is Nothing Then
Set rLock = .Cells(i, "Z").EntireRow
Else
Set rLock = Application.Union(rLock, .Cells(i, "Z").EntireRow)
End If
Else
If rUnlock Is Nothing Then
Set rUnlock = .Cells(i, "Z").EntireRow
Else
Set rUnlock = Application.Union(rUnlock, .Cells(i, "Z").EntireRow)
End If
End If
Next i
If Not rLock Is Nothing Then rLock.Locked = True
If Not rUnlock Is Nothing Then rUnlock.Locked = False
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
End Sub
It will be faster still you could incorporate use of Variant Arrays on the loop
On my hardware it takes about 6 s to process 500,000 rows
Try with this solution which seems to be much faster than original one:
Private Sub Lock_Rows_new(ByVal Target As Range)
Debug.Print "s:" & Timer
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Set DestSh = Worksheets(8) 'Data tab for Item 1
With DestSh
'range to search
Dim firstRNGRow As Variant '!! important
firstRNGRow = 26
Dim firstRNG As Range
Set firstRNG = .Cells(firstRNGRow, "Z")
Dim lastRNG As Range
Set lastRNG = .Cells(.Range("B" & .Rows.Count).End(xlUp).Row, "Z")
'unlock all
Range(firstRNG, lastRNG).EntireRow.Cells.Locked = False
'search for first done
firstRNGRow = Application.Match("Done", Range(firstRNG, lastRNG), 0)
Do While (Not IsError(firstRNGRow))
Set firstRNG = .Cells(firstRNG.Row + firstRNGRow, "Z")
firstRNG.Offset(-1, 0).EntireRow.Cells.Locked = True 'lock the row
If firstRNG.Row > lastRNG.Row Then Exit Do
firstRNGRow = Application.Match("Done", Range(firstRNG, lastRNG), 0)
Loop
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
Debug.Print "e:" & Timer
End Sub
Edited to add a faster solution combining Sort() and AutoFilter()
AutoFilter() can make things fast:
Private Sub Lock_Rows(ByVal Target As Range)
With Worksheets(8)
If IsEmpty(.Range("Z25")) Then .Range("Z25").Value = "xxx" ' be sure you have a column "header" for data in column Z from row 26 downwards
With .Range("Z25:Z" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.EntireRow.Locked = False ' unlock all cells
.AutoFilter field:=1, Criteria1:="Done"
With Intersect(ActiveSheet.UsedRange, .EntireColumn).Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).EntireRow.Locked = True ' lock only filtered range rows
End With
End With
If .Range("Z25").Value = "xxx" Then .Range("Z25").ClearContents ' remove any "not original" column header
End With
End Sub
if you know that cell Z25 content is always not empty then you can omit the lines:
If IsEmpty(.Range("Z25")) Then .Range("Z25").Value = "xxx"
If .Range("Z25").Value = "xxx" Then .Range("Z25").ClearContents
and if you Sort things, it's even faster:
Option Explicit
Private Sub Lock_Rows(ByVal Target As Range)
Dim dataRange As Range, sortRange As Range, lockRange As Range
With Worksheets("8") ' reference wanted sheet
Set dataRange = .Range("Z25", .Cells(.Rows.Count, "B").End(xlUp))
Set lockRange = Intersect(.Columns("Z"), dataRange)
Set sortRange = Intersect(dataRange.EntireRow, .UsedRange.Columns(.UsedRange.Columns.Count + 1)) ' reference the range in same rows as referenced one but in first "not used" column
Set dataRange = .Range(dataRange, sortRange)
End With
With sortRange
.Formula = "=ROW()" ' write rows indexes in referenced range. this will be used to sort things back
.Value = .Value ' get rid of formulas
End With
dataRange.Sort key1:=lockRange.Resize(1), order1:=xlAscending, Header:=xlYes ' sort data on columns with possible "Done" values
If IsEmpty(lockRange(1, 1)) Then lockRange(1, 1).Value = "xxx" ' remove any "not original" column header
With dataRange ' reference referenced sheet column B range in
.AutoFilter field:=lockRange.Column - Columns(1).Column, Criteria1:="Done"
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).EntireRow.Locked = True ' lock only filtered range rows
End With
.Parent.AutoFilterMode = False
.Sort key1:=sortRange.Resize(1), order1:=xlAscending, Header:=xlYes ' sort things back
sortRange.ClearContents ' delete rows index, not needed anymore
End With
If lockRange(1, 1).Value = "xxx" Then lockRange(1, 1).ClearContents ' remove any "not original" column header
End Sub
again, if you know that cell Z25 content is always not empty then you can omit the lines:
If IsEmpty(lockRange(1, 1)) Then lockRange(1, 1).Value = "xxx" ' remove any "not original" column header
If lockRange(1, 1).Value = "xxx" Then lockRange(1, 1).ClearContents ' remove any "not original" column header

Paste to another cell and WS while looping and shifting down a row

I am looking for some help in getting this code to run properly. I've gotten some help with the first part from some great people here!
Basically, the code I have now sets ranges in between cells formatted bold, as the bold represents a date. I am trying to find the individual segments in column A and copy the coresponding number in column D to another worksheet in column C. If the value is not found in the range, the row output should shift down one without filling in anything.
Here is what I have so far:
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.sheets("FC01.RPT")
Set MoBWS = thisWB.sheets("Mix of Business")
'--- find the first bold cell...
Dim nextBoldCell As range
Set nextBoldCell = FindNextBoldInColumn(dataWS.range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
'Set lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Do
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
sheets("FC01.RPT").Select
Cells.Find(What:="Individual return guest").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Plan").Select
range("C3").Select
ActiveSheet.Paste
Next i
startOfDataRow = endOfDataRow + 1
Loop
'Do While endOfDataRow < lastRowOfAllData
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
Public Function FindNextBoldInColumn(ByRef startCell As range, _
Optional columnNumber As Long = 1) As range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As range
Set checkCell = startCell
Do While Not checkCell.Font.bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
The code keeps crashing. How can I make it so the output line shifts down one when looping though a range, no matter if it finds the value or not?
Does anyone know what do to?
Here is a snapshot of the data I am working with:
Thanks for the help!!
I noticed all your "blocks" end with some "Summe" occurrence in column A, and data begins at row 14
then I'd go this way:
Sub mm()
Dim iArea As Long
With Worksheets("FC01.RPT")
With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
.Cells(2, 1).Value = "Summe"
.AutoFilter field:=1, Criteria1:="Summe*"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
For iArea = 1 To .Areas.Count - 1
With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1))
Worksheets("Plan").Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = WorksheetFunction.SumIf(.Cells, "Individual*", .Offset(, 3))
End With
Next
End With
.Cells(2, 1).ClearContents
End With
.AutoFilterMode = False
End With
End Sub

How can I delete all rows that do not include a specific value?

I have been struggling with this for a few hours and think it's probably time to ask for help.
I have hundreds of spreadsheets that I would like to manually open and then simplify using a macro. Each spreadsheet has a list of hospitals (approx 400) and I would like to limit each one to only showing data about 100 hospitals. The hospitals are identified by a three letter acronym in a column that varies in location (row/column) but is always titled "Code".
So, for example, I would like the macro to delete all rows that do not contain the values "Code", "ABC", "DEF", "GEH", etc.
I am not a regular Excel user and only need to use it to solve this one problem...!
I have tried the code attached but it has a couple of bugs:
It deletes rows that contain "ABC" as well. This problem goes away if I define Range("B1:B100") but not if the range extends across multiple columns (e.g. "A1:E100"). Frustratingly the "Code" column varies across the spreadsheets.
As I want to save 100 hospital codes, it feels as if there ought to be a better way than using the "Or" operator 100 times.
Can anyone help?
Sub Clean()
Dim c As Range
Dim MyRange As Range
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
Set MyRange = Range("A1:E100")
For Each c In MyRange
If c.Value = "Code" Then
c.EntireRow.Interior.Color = xlNone
ElseIf c.Value = "ABC" Or c.Value = "DEF" Then
c.EntireRow.Interior.Color = vbYellow
Else
c.EntireRow.Delete
End If
Next
End Sub
Try this:
Option Explicit
Sub Clean()
Dim rngRow As Range
Dim rngCell As Range
Dim MyRange As Range
Dim blnDel As Boolean
Dim lngCount As Long
Set MyRange = Range("A1:E8")
For lngCount = MyRange.Rows.Count To 1 Step -1
blnDel = False
For Each rngCell In MyRange.Rows(lngCount).Cells
If rngCell = "ABC" Then
rngCell.EntireRow.Interior.Color = vbRed
blnDel = True
ElseIf rngCell = "DEF" Then
rngCell.EntireRow.Interior.Color = vbYellow
blnDel = True
End If
Next rngCell
If Not blnDel Then Rows(lngCount).Delete
Next lngCount
End Sub
In general, you need to loop through the rows, and then through each cell in every row. In order for the program to remember whether something should be deleted or not on a given row, between the two loops there is a blnDel, which deletes the row, if no DEF or ABC was found.
The problematic part in rows deletion in VBA, is that you should be careful to delete always the correct one. Thus, you should make a reversed loop, starting from the last row.
Option Explicit
Sub Clean()
Dim c As Range, MyRange As Range, DelRng As Range, Code As Range, CodeList As Range
Dim CodeCol As Long, LastRow As Long
''Uncomment the below. I'd put all of your codes into one sheet and then test if the value is in that range
'With CodeListSheet
' Set CodeList = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
'End With
' Update this to point at the relevant sheet
' If you're looking at multiple sheets you can loop through the sheets starting your loop here
With Sheet1
Set Code = .Cells.Find("Code")
If Not Code Is Nothing Then
CodeCol = Code.Column
LastRow = .Cells(Cells.Rows.Count, CodeCol).End(xlUp).Row
Set MyRange = .Range(.Cells(1, CodeCol), .Cells(LastRow, CodeCol))
For Each c In MyRange
If c.Value2 = "Code" Then
c.EntireRow.Interior.Color = xlNone
'' Also uncomment this one to replace your current one
'ElseIf WorksheetFunction.CountIf(CodeList, c.Value2) > 0 Then
ElseIf UCase(c.Value2) = "ABC" Or c.Value2 = "DEF" Then
c.EntireRow.Interior.Color = vbYellow
Else
If DelRng Is Nothing Then
Set DelRng = c
Else
Set DelRng = Union(DelRng, c)
End If
End If
Next c
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete
Else
MsgBox "Couldn't find correct column"
Exit Sub
End If
End With
End Sub

Check merged cell and compare adjacent to set unique value from compared cells values

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

Copy/Paste multiple rows in VBA

I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With