The below code searches, copies & pastes the found data into another worksheet. However, there are blanks when this is done in the pasted worksheet. Eg: Found "To Be Copied" in Cell A1 and copied the entire row to the specified worksheet. Found "To Be Copied" in A4 and copied the entire row to the specified worksheet. However, there are two blank rows in the pasted sheet between A1 and A4. Thanks for your help.
Sub Deleting()
Application.ScreenUpdating = False
Dim wsh As Worksheet, i As Long, Endr As Long, x1 As Worksheet, p As Long
Set wsh = ActiveSheet
Worksheets.Add(Before:=Worksheets("Original Sheet")).Name = "Skipped"
Set x1 = Worksheets("Skipped")
Worksheets("ABC").Activate
i = 2
Endr = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
While i <= Endr
If Cells(i, "A") = "To Be Copied" Then
wsh.Rows(i).Copy
x1.Rows(i).PasteSpecial
p = p + 1
Endr = Endr + 1
End If
i = i + 1
Wend
End Sub
You need two counters: i for the source rows, j for the destination rows. You only increment j when a row is copied.
Your existing code needs either
A separate counter for the written row position (Cutter's point), or
Pasting to the last used row of "Skipped" using xlUp to find the last used cell
But better still would be copying the rows in a single shot using AutoFilter. Something like below
Sub Quicker()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("ABC")
Set ws2 = Worksheets.Add(Before:=Worksheets("Original Sheet"))
'in case Skipped exists
On Error Resume Next
ws2.Name = "Skipped"
On Error GoTo 0
ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "To Be Copied"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
rng1.EntireRow.Copy ws2.[a1]
End If
ws1.AutoFilterMode = False
MsgBox "Sheet " & ws2.Name & " updated"
End Sub
Related
I am building out a workbook where every sheet is for a different stage of a software installation. I am trying to aggregate the steps that fail by copying my fail rows into a summary sheet. I finally got them to pull, but they are pulling into the new sheet on the same row # as they are located in the original sheet.
Here is what I am using now:
Option Explicit
Sub Test()
Dim Cell As Range
With Sheets(7)
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Fail" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next Cell
End With
End Sub
I need to:
Pull row that has cell containing "Fail"
Copy row into master starting at Row 4 and consecutively down without overwriting
Run across all sheets at once-
*(they are named per step of install - do i need to rename to "sheet1, sheet2, etc"????)
When macro is run clear previous results (to avoid duplicity)
Another user offered me an autofilter macro but it is failing on a 1004 at this line ".AutoFilter 4, "Fail""
Sub Filterfail()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")
Application.ScreenUpdating = False
'sh.UsedRange.Offset(1).Clear 'If required, this line will clear the Master sheet with each transfer of data.
For Each ws In Worksheets
If ws.Name <> "Master" Then
With ws.[A1].CurrentRegion
.AutoFilter 4, "Fail"
.Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
.AutoFilter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this:
The text “Completed” in this xRStr = "Completed" script indicates the specific condition that you want to copy rows based on;
C:C in this Set xRg = xWs.Range("C:C") script indicates the specific column where the condition locates.
Public Sub CopyRows()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("C:C")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = xRStr Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Here's another way - You'll have to assign your own Sheets - I used 1 & 2 not 2 & 7
Sub Test()
Dim xRow As Range, xCel As Range, dPtr As Long
Dim sSht As Worksheet, dSht As Worksheet
' Assign Source & Destination Sheets - Change to suit yourself
Set sSht = Sheets(2)
Set dSht = Sheets(1)
' Done
dPtr = Sheets(1).Rows.Count
dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
For Each xRow In sSht.UsedRange.Rows
Set xCel = xRow.Cells(1, 1) ' xCel is First Column in Used Range (May not be D)
Set xCel = xCel.Offset(0, 4 - xCel.Column) ' Ensures xCel is in Column D
If xCel.Value = "Fail" Then
dPtr = dPtr + 1
sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
End If
Next xRow
End Sub
I think one of the problems in your own code relates to this line
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
The section Rows.Count, "A" should be referring to the destination sheet(2) but isn't because of the line
With Sheets(7)
further up
I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.
Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.
I would also like to know how i can set up the keyword to use information in Column A of the Field List.
Sub FinalAppendVar()
Dim ws As Worksheet
Dim arr() As String
Keyword = "adj_veh_smart_tech_disc"
Totalsheets = Worksheets.Count
For i = 1 To Totalsheets
If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name
<>_ "Field Lists" Then
lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If Worksheets(i).Cells(1, 3).Value = Keyword Then
Worksheets("Field Lists").Activate
lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
End If
Next
End If
Next
End Sub
The following code should work for what you described.
A couple feedback items:
Tabbing out loops and if statements significantly improves code readability
Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
.Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing
Sub FinalAppendVar()
Dim searchSheet As Excel.Worksheet
Dim pasteSheet As Excel.Worksheet
Dim keyword As String
Dim lastSearchRow As Integer
Dim lastPasteRow As Integer
' set the worksheet to paste to
Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
' set keyword to look for
keyword = "adj_veh_smart_tech_disc" '<-- manual entry
'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
' loop through all sheets in the workbook
For i = 1 To ThisWorkbook.Worksheets.Count
' set the current worksheet we are looking at
Set searchSheet = ThisWorkbook.Worksheets(i)
' check if the current sheet is one we want to search in
If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
' current worksheet is one we want to search in
' find the last row of data in column D of the current sheet
lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
' loop through all rows of the current sheet, looking for the keyword
For j = 2 To lastSearchRow
If searchSheet.Cells(j, 3).Value = keyword Then
' found the keyword in row j of column C in the current sheet
' find the last row of column D in the paste sheet
'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
' paste the name of the current search sheet to the last empty cell in column E
pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
' not sure if the next line is needed, looks like it pastes again immediately below the previous
pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
' to save time consider exiting the search in the current sheet since the keyword was just found
' this will move to the next sheet immediately and not loop through the rest of the rows on the current
' search sheet. This may not align with the usecase so it is currently commented out.
'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
Else
' the keyoword was not in row j of column C
' do nothing
End If
Next j
Else
' current sheet is one we don't want to search in
' do nothing
End If
Next i
End Sub
Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):
Option Explicit
Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
On Error Resume Next
Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
On Error GoTo 0
If wsTarget Is Nothing Then
MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
Exit Sub
End If
Rem Clear all previous results (from column B to end of data)
wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
sKeyword = keywordCell.Text
If Trim(sKeyword) <> vbNullString Then
Application.StatusBar = "Processed '" & sKeyword & "'"
Set linkCell = keywordCell
For Each wsEach In ActiveWorkbook.Worksheets
If wsEach.Name <> LIST_SHEET_NAME Then
Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
Set aFound = FindAll(wsEach.UsedRange, sKeyword)
If Not aFound Is Nothing Then
For Each aCell In aFound
Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
Next aCell
End If
End If
Next wsEach
End If
Next keywordCell
Application.StatusBar = False
Rem Column width
wsTarget.UsedRange.Columns.AutoFit
End Sub
Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
You can see how it works in this demo workbook - Create Links To Keywords.xlsm
EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.
For each worksheet in my workbook, I would like to:
- Check if rows contain cells with colour index -4142 (yellow)
- If yes, copy and paste row values into ToDo list.
I have tried:
1) For Each loop, as indicated below.
2) Dim i As Long
For i = 1 To ThisWorkbook.Worksheets.Count
Set Sh1 = Worksheets(i)
Sub Macro1()
Dim wrk As Workbook
Dim colCount As Integer
Dim ws As Worksheet
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, r1 As Range, cell As Range
Dim iResponse As Integer
Dim LastRow As Long
iResponse = MsgBox("Do you want to COPY your 'Current List' (Hi-lighted rows) to the 'Select List' sheet?", vbYesNoCancel + vbQuestion + vbDefaultButton3, "Copy Selected Results To View In Select List")
Select Case iResponse
Case vbCancel
MsgBox "Cancelled", vbOKOnly + vbExclamation, "Cancelled copy"
Case vbNo: 'do Nothing
MsgBox "Doing nothing", vbOKOnly + vbInformation, "Doing nothing"
Case vbYes
For Each ws In ActiveWorkbook.Worksheets ' For each worksheet in workbook
Set Sh1 = Worksheets(ws.Index) ' Sh1 will be first, second, etc. worksheet
Set Sh2 = Worksheets("ToDo") ' sheet to copy to
Set wrk = ActiveWorkbook ' to get header as first row
colCount = Sh1.Cells(1, 255).End(xlToLeft).Column
With Sh2.Cells(1, 1).Resize(1, colCount)
.Value = Sh1.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True
End With
Set r1 = Sh1.Range(Sh1.Cells(2, "D"), Sh1.Cells(Rows.Count, "C").End(xlUp))
For Each cell In r1
If cell.Interior.ColorIndex = 6 Then
If r Is Nothing Then
Set r = cell
Else
Set r = Union(r, cell)
End If
End If
Next
If Not r Is Nothing Then
LastRow = Sh2.Cells(Rows.Count, "C").End(xlUp).Row
With Sh2
r.EntireRow.Copy Destination:=.Range("A" & LastRow + 1)
.UsedRange.Offset(1).Interior.ColorIndex = -4142
Range("A1").Select
End With
Else
MsgBox "No info obtained", vbExclamation, "Nothing copied."
End If
Exit For ' Exit For loop
Next ws ' Next worksheet
End Select
End Sub
The expected output is:
If Sheet 1 has 3 rows - row 1: yellow, row 2: green, row 3: yellow
and Sheet 2 has 2 rows - row 1: yellow, row 2: blue
then ToDo sheet will show the values of Sheet 1 row 1, Sheet 1 row 3, Sheet 2 row 2
Currently the output is "No info obtained" msg.
This runs through each cell in the usedrange of each worksheet. If the interior color matches it copies all the values from that row, and puts it in the ToDo list worksheet. If the row counter for the todo list hasn't changed after the loops were complete then "no info obtained" message will pop up.
Option Explicit
Sub Test()
Dim oToDo As Worksheet
Set oToDo = Worksheets("ToDo")
Dim oToDoRow As Long
oToDoRow = 2 ' Whatever row your "todo" data starts on
Dim oCell As Range
Dim oCurWS As Worksheet
Dim oPrevRow As String
For Each oCurWS In ThisWorkbook.Worksheets
If oCurWS.Name <> "ToDo" Then
For Each oCell In oCurWS.UsedRange
' I used Interior Color you should be able to use colorindex in the same way
If oCell.Interior.Color = 65535 Then
If oPrevRow <> oCurWS.Index & "_" & oCell.Row Then
oToDo.Rows(oToDoRow).Value = oCurWS.Rows(oCell.Row).Value
oPrevRow = oCurWS.Index & "_" & oCell.Row
oToDoRow = oToDoRow + 1
End If
End If
Next
End If
Next
' Match oToDoRow with whatever is set as default at the top
If oToDoRow = 2 Then MsgBox "No info obtained"
End Sub
Update to prevent row being listed multiple times if more than one cell in a row was highlighted.
Do you need whole row to be "yellow" ? or there is allways one cell in each row ?.
I'm asking what if A1 is yellow ,B1 is blue, C1 is red, D1 is yellow you want to copy from this row only A1 and D1 to Sheet "ToDo"- into A1 and B1 or copy/paste entire row?
Have a great day
1) My vba copies and pastes columns from sheet a to sheet b (a table) .
2) My next vba code is ran ontop of this table and I get an error.
However if I copy and paste the problem header and data manually from sheet A to Sheet B my macro(2) will work.
Also I should mention this particular column causing the problem is a column with dates. But I have tried both formats, general and date, ive tried using a formula (=SheetA!BU1:) and pasted down into sheet 2, and I've tried a macro to copy and paste the one column.. nothing works!
Not sure if it is my code, table, format, etc.
Here is my copy and paste macro, the type mismatch does not occur here but in my other code that is not included.
Sub importtodatabase(from_ws, to_ws)
Dim rng As Range, trgtCell As Range
Dim src As Worksheet
Dim trgt As Worksheet
Set src = Worksheets(from_ws)
Set trgt = Worksheets(to_ws)
Dim row_num As Integer
Dim Max_row_data As Integer
Dim source_tab As String
Application.ScreenUpdating = False
Sheets(to_ws).Select
Max_row_data = get_max_row("")
If Max_row_data <> 2 Then
Max_row_data = Max_row_data + 1
End If
Sheets("Mappings").Select
max_row = get_max_row("")
With src
For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
For row_num = 2 To max_row
If from_ws = Range("BU" & row_num).value Then
If rng = Range("BV" & row_num).value Then
rng = Range("BW" & row_num).value
Exit For
End If
End If
Next row_num
Set trgtCell = trgt.Rows(1).Find(rng.value, LookIn:=xlValues, lookat:=xlWhole)
'If .Range(rng.Offset(1), .Cells(ws.Rows.Count, "A").End(xlUp).row
If Not trgtCell Is Nothing Then
.Range(rng.Offset(1), .Cells(.Rows.count, rng.Column).End(xlUp)).copy
With trgt
.Cells(Max_row_data, trgtCell.Column).PasteSpecial xlPasteValues
End With
End If
'End If
Next rng
End With
Application.ScreenUpdating = False
End Sub
I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub