I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...
Related
I have a simple loop that should copy ranges form three sheets and stack them on top of each other in another sheet. I define the ranges of each of the three sheets via a cell that counts rows in the Control Sheet.
I do not get an error message, however only the range of the first sheets gets pasted. I troubleshooted already to see if the loop is running until end and indeed it does. I cannot wrap my head around why only the range from the first sheets gets pasted in the final sheet.
Sub Loop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("d")
ws_Sheet.Cells.ClearContents
counter = 1
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
lng_LastRow = Worksheets("Control").Range("E" & counter).Value + 1
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
counter = counter + 1
Next i
End Sub
The issue is
lng_LastRowSheet = ws_Sheet.Cells(Rows.Count, 1).End(xlUp).Row
is the last used row (the last row that has data).
And then you use that to start pasting
rng_WorkRange.Copy ws_Sheet.Range("A" & lng_LastRowSheet)
so you overwrite the last row of data!
The next free row is lng_LastRowSheet + 1 so you should paste there:
rng_WorkRange.Copy ws_Sheet.Range("A" & (lng_LastRowSheet + 1))
You can also see that in the debug data:
a $A$1:$B$338 to A1
b $A$1:$B$91 to A338
c $A$1:$B$356 to A428
a goes from A1:B338 but you start pasting b in A338 so it overwrites the last row of a.
I gave it a test:
Created worksheet Control with data like
Then created worksheets a, b and c like
with data until row 500 so there is enough.
Then created an empty worksheet d for the output.
And used the following code. Note I have optimized it so it uses meaningful variable names, which is much easier to read, understand and debug.
Option Explicit
Public Sub CopyData()
Dim SheetNames() As Variant
SheetNames = Array("a", "b", "c")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets("d")
wsDestination.Cells.ClearContents
Dim i As Long
For i = 0 To 2
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets(SheetNames(i))
Dim SourceLastRow As Long
SourceLastRow = ThisWorkbook.Worksheets("Control").Range("E" & i + 1).Value + 1
Dim SourceLastColumn As Long
SourceLastColumn = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Dim DestinationFreeRow As Long
DestinationFreeRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Row + 1 ' Last used row +1
Dim SourceRange As Range
Set SourceRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(SourceLastRow, SourceLastColumn))
SourceRange.Copy wsDestination.Range("A" & DestinationFreeRow)
Next i
End Sub
And I get a perfect output like:
Note that in the output I have hidden some rows so you can see eveything is there. This code perfectly does what it is supposed to.
Stack Ranges (Vertically) From Multiple Worksheets
Sub StackRanges()
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sWorksheetNames() As Variant: sWorksheetNames = VBA.Array("a", "b", "c")
' Lookup (Source Last Row)?
Dim lws As Worksheet: Set lws = wb.Worksheets("Control")
Dim llrCell As Range: Set llrCell = lws.Range("E1")
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("d")
dws.UsedRange.ClearContents
Dim dfCell As Range: Set dfCell = dws.Range("A1")
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
Dim slColumn As Long
Dim i As Long
' Loop.
For i = 0 To UBound(sWorksheetNames)
Set sws = wb.Worksheets(sWorksheetNames(i))
slRow = llrCell.Value + 1
slColumn = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range("A1", sws.Cells(slRow, slColumn))
srg.Copy dfCell
' If you only need to copy values (since you're using '.ClearContents'),
' instead, use the most efficient:
'dfCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set llrCell = llrCell.Offset(1) ' next source last row lookup cell
Set dfCell = dfCell.Offset(srg.Rows.Count) ' next first dest. cell
Next i
End Sub
The counter and the lng_lastRow variable is too messy.
I repaleced some code as follow：
Sub newLoop()
Dim ws_Sheet As Worksheet, ws As Worksheet
Dim lng_LastRow As Long, lng_LastColumn As Long, lng_LastRowSheet As Long
Dim rng_WorkRange As Range, rng_lastRange As Range
Dim arrSht, i
Dim counter As Integer
arrSht = Array("a", "b", "c")
Set ws_Sheet = Worksheets("Control")
ws_Sheet.Cells.ClearContents
For i = 0 To 2
Set ws = Worksheets(arrSht(i))
Set rng_lastRange = ws_Sheet.Cells(Rows.Count, 1).End(xlUp)
lng_LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lng_LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng_WorkRange = ws.Range(ws.Cells(1, 1), ws.Cells(lng_LastRow, lng_LastColumn))
rng_WorkRange.Copy rng_lastRange.Offset(1, 0)
Next i
End Sub
I have this program to copy an entire row to another sheet within the same workbook depending on if the person's name (pulled from let's say Sheet 1) is found to be on another spreadsheet (sheet 2).
The department is then used (From sheet 1) to place the name that is found on sheet 2 on the department specific sheet.
It is only printing the first instance of the condition and nothing else on every department page.
Main:
Sub copy2Sheets()
Dim table As Worksheet: Set table = Worksheets("Table")
Dim N As Long
N = 117
Dim i As Long
Dim tempDep As String
Dim tempName As String
tempDep = table.Cells(1, "B").value
tempName = table.Cells(1, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
'Loop Case:
For i = 2 To N - 1
tempDep = table.Cells(i, "B").value
tempName = table.Cells(i, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
Next i
End Sub
PasteFunction:
Sub copyPaste(Name As String, place As Worksheet)
'Worksheet Variables
Dim wsSource As Worksheet
Dim targSource As Worksheet: Set targSource = place
'CurrentLast Row As Long
Dim iTargetRow As Long
'Which Cell was Found
Dim FoundCell As Range
Dim copyTo As Long: copyTo = targSource.Cells(Rows.count, "A").End(xlUp).Row
'Assign Variables
Set wsSource = Worksheets("Last Month's BBS SafeUnsafe by ")
Set FoundCell = check(Name)
If Not FoundCell Is Nothing Then
copyTo = copyTo + 1
wsSource.Cells(FoundCell.Row).EntireRow.Copy targSource.Range("A" & copyTo)
End If
End Sub
Check function:
Public Function check(Name As String) As Range
Dim Rng As Range
Dim ws As Worksheet: Set ws = Worksheets("Last Month's BBS SafeUnsafe by ")
If Trim(Name) <> "" Then
Set Rng = ws.Range("C:C").Find(Name)
If Not Rng Is Nothing Then
Set check = Rng
End If
End If
End Function
Example Excel Sheets:
"Sheet 1"
Sheet 2
In the images, only the first entry from sheet 2 is being copied into every sheet, rather than every entry being pasted into their respective sheets.
Splitting up your code like that makes it more difficult to follow - try only using one method:
Sub copy2Sheets()
Const N As Long = 116 'use const for fixed values
Dim wsTable As Worksheet, wsBBS As Worksheet, i As Long
Dim wsDest As Worksheet, f As Range, tempDep As String, tempName As String
Set wsTable = ThisWorkbook.Worksheets("Table")
Set wsBBS = ThisWorkbook.Worksheets("Last Month's BBS SafeUnsafe by ")
For i = 1 To N
tempDep = Trim(wsTable.Cells(i, "B").Value)
tempName = Trim(wsTable.Cells(i, "A").Value)
If Len(tempName) > 0 Then
Set wsDest = ThisWorkbook.Worksheets(tempDep)
Set f = wsBBS.Columns("C").Find(what:=tempName, lookat:=xlWhole)
If Not f Is Nothing Then
f.EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next i
End Sub
I have a worksheet with sales data, I've managed to create Autofilter based on department and copied the results into the new sheet (Output). What I'm trying to achieve is that code will multiply the results of respective month by value in "Adjustment" row.
So the result is following
Is there a way how to process calculations within my code or I shall multiply each column in different Sub afterwards?
Dim Last_Row As Long
Dim DbExtract, DuplicateRecords As Worksheet
Dim WKS2 As Worksheet
Dim rn As Range
Set DbExtract = ThisWorkbook.Sheets("Data")
Set DuplicateRecords = ThisWorkbook.Sheets("Output")
Set WKS2 = ThisWorkbook.Sheets("Dashboard")
iMultiplier = WKS2.Range("Z18")
Application.ScreenUpdating = False
Last_Row = DuplicateRecords.Range("A" & Rows.Count).End(xlUp).Row + 1
DbExtract.Range("C3:R1500").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A" & Last_Row).PasteSpecial
DuplicateRecords.Range("$A$1:$P$400").AutoFilter Field:=3, Criteria1:=WKS2.Range("V2")
Set rn = DuplicateRecords.Range("G2:G500").SpecialCells(xlCellTypeVisible)
For Each cell In rn
iNewnumber = cell * iMultiplier
Next cell
End Sub
Here's an example:
Sub Tester()
Dim lastRow As Long, wb As Workbook
Dim wsData As Worksheet, wsOutput As Worksheet
Dim wsDash As Worksheet, rngVis As Range, numVisRows As Long
Dim rn As Range, rngAdj As Range, m As Long, adj, c As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data") 'consistent naming helps...
Set wsOutput = wb.Sheets("Output")
Set wsDash = wb.Sheets("Dashboard")
'iMultiplier = wsDash.Range("Z18") '?
Application.ScreenUpdating = False
Set rngVis = wsData.Range("C3:R1500").SpecialCells(xlCellTypeVisible)
numVisRows = rngVis.Cells.Count / rngVis.Columns.Count
rngVis.Copy
lastRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1 'start of pasted data
wsOutput.Range("A" & lastRow).PasteSpecial
Set rngAdj = wsDash.Range("C5:N5") 'for example
For m = 1 To rngAdj.Columns.Count 'loop the cells in the adjustments range
adj = rngAdj.Cells(m).Value 'adjustment value
If Len(adj) > 0 And IsNumeric(adj) Then 'have an adjustment to make?
'loop the relevant cells in the pasted data
For Each c In wsOutput.Cells(lastRow, "A").Offset(0, 2 + m).Resize(numVisRows).Cells
If Len(c.Value) > 0 And IsNumeric(c.Value) Then 'any thing to adjust?
c.Value = c.Value * adj
End If
Next c
End If
Next m
End Sub
My code currently searches through Sheet1 and copies rows into Sheet2 if it matches the array of strings in strSearch. How can I make it so that it outputs "No Search Found" as a row on Sheet2 if there are no rows that contain the strSearch?
Dim ws1 As Worksheet, ws2 As Worksheet
Dim firstRowWs1 As Long
Dim lastRowWs1 As Long
Dim lastRowWs2 As Long
Dim searchColumnWs1 As Integer
Dim i As Integer
Dim check As Variant
Dim strSearch As Variant
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
With ws2
lastRowWs1 = ws1.UsedRange.Rows.Count
lastRowWs2 = ws2.UsedRange.Rows.Count
firstRowWs1 = 1
searchColumnWs1 = 10
strSearch = Array("John", "Jim")
For i = firstRowWs1 To lastRowWs1
For Each check In strSearch
If check = ws1.Cells(i, searchColumnWs1).Value Then
ws1.Rows(i).Copy (ws2.Rows(lastRowWs2 + 1))
ws2.Rows(lastRowWs2 + 1).Columns("A:B").Insert xlToRight
lastRowWs2 = lastRowWs2 + 1
ws1.Rows(i).Delete shift:=xlUp
i = i - 1
Exit For
End If
Next check
Next i
End With
Keep track of whether or not you found matches, and add the text after your loop.
Eg:
Dim foundMatches as Boolean
foundMatches = False
For i = firstRowWs1 To lastRowWs1
For Each check In strSearch
If check = ws1.Cells(i, searchColumnWs1).Value Then
foundMatches = True
... etc
End If
Next check
Next i
If Not foundMatches then
' print "no rows found" somewhere
end if
Despite reading several threads searching for answers to similar problems I have been unable to debug my code on its own.
I am trying to write a macro that will search all cells between AE and BF for the term "Aeronautics Engineers" and then copy all rows that contain that term to a new sheet. The entire sheet has a total of 99289.
I have tried using the following code without any luck:
Sub MoveAero()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("Aeronautic")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
Thanks for any assistance!
Your problem is in your j loop:
For J = 0 To UBound(strArray)
The UpperBound (Ubound) of array strArray is 0. It's an array with a single element "Aeronautic".
So your loop is looping once and exiting.
Instead try looping through your range:
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
Found = True
Exit For
End if
Next rngCell
Here we loop through that rngCells range that you just made, cell by cell. Then we test if if the cell has the value you are looking for. If we find it, we set found to true and exit the for loop. You don't have to exit the for loop, but we found what we wanted, so there is no reason not to save some cpu time.
Full code, removed unnecessary variables and moved a little bit around:
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngCell as Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
'Moved this logic up from the IF block below
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
Exit For
End if
Next rngCell
Next I
End Sub
Alternatively, you could use that .find method of the range object instead of the second For loop. (Using both for your needs is unnecessary).
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
'Try to find your search term in the range
If Not (rngCells.Find("Aeronautic") Is Nothing) Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub