I'm trying to write a macro to put the name of the steward in a cell if they are assigned to that category. I wrote this code so far but it isn't working. I'm trying to get it so that if a cell of a column in one worksheet matches the cell of another worksheet and if it does, then it will print the name of the steward in a separate cell to identify that that category is owned by that person.
The numbers are in the worksheet Demetri in the range of E27 to E38 and I want to see if the cells in the range BE4 to BE163803 from the worksheet Share_Dump are in the range from the Demetri worksheet.
Sub steward_products()
Dim d, s As Worksheet
Set d = Worksheets("Demetri")
Set s = Worksheets("Share_Dump")
For i = 4 To 163803 Step 1
For j = 27 To 38 Step 1
If s.Cells(i, 3) = d.Cells(j, 5) Then
s.Cells(i, 57) = "Demetri"
End If
Next j
Next i
Please try this code. I think it will do what you need.
Option Explicit
Sub Steward_Products()
' 236
' use descriptive names and use the declarations to explain them
' use Option Explicit and capitalization to avoid typos
Dim WsSteward As Worksheet ' Demetri
Dim WsDump As Worksheet ' Share_Dump
Dim Fnd As Range
Set WsSteward = Worksheets("Demetri")
Set WsDump = Worksheets("Share_Dump")
With WsDump
' presuming that columns 28:38 are not longer than column 27
Set Fnd = .Range(.Cells(4, 27), .Cells(.Rows.Count, 27).End(xlUp)) _
.Resize(, 12)
Set Fnd = Fnd.Find(WsSteward.Cells(5, "J").Value, _
LookIn:=xlValues, LookAt:=xlWhole)
If Fnd Is Nothing Then
MsgBox "Product """ & WsSteward.Cells(5, 10).Value & """ wasn't found.", _
vbInformation, "Invalid product description"
Else
.Cells(Fnd.Row, 57) = "Demetri"
End If
End With
End Sub
Related
all.
I'm running this code:
Sub ISN_Flyer_Performance()
Dim FlyerSh As Worksheet
Dim QlikSh As Worksheet
Dim SKURng As Range
Dim QlikSKURng As Range
Dim SKU As Range
Dim qlr As Long
Dim QlikSKU As Range
Dim TotalSales As Double
Dim FirstQlikSku As Range
Set FlyerSh = ActiveSheet
i = 2
lr = FlyerSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSh = Application.InputBox("Click any cell on the Qlikview Sheet you want to lookup against", "Find Qlikview Sheet", Type:=8).Worksheet
qlr = QlikSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSKURng = Range(Cells(2, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column), Cells(qlr, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column))
Set SKURng = Range(FlyerSh.Cells(i, 1), FlyerSh.Cells(lr, 1))
Set SKU = FlyerSh.Cells(i, 1)
For Each SKU In SKURng
Set QlikSKU = QlikSKURng.Find(What:=SKU.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If QlikSKU Is Nothing Then
SKU.Offset(0, 2).Value = 0
GoTo NextSku
Else
TotalSales = QlikSKU.Offset(0, 5).Value
Set FirstQlikSku = QlikSKU
Do
Set QlikSKU = QlikSKURng.FindNext(QlikSKU)
If QlikSKU.Address = FirstQlikSku.Address Then Exit Do
TotalSales = TotalSales + QlikSKU.Offset(0, 5).Value
Loop
SKU.Offset(0, 2) = TotalSales
End If
NextSku:
Next SKU
End Sub
It's essentially like an XLookup, where it gets the thing to seach on one workbook, then finds it on a second, sends the value back to the first one, and moves on to the next item. I'd use an XLookup, but unfortunately, my sheet will always have duplicates, and I need to count both.
So I'm using this findnext loop to loop through a range (QlikSKURange) which has about 16k rows. The findNext is reasonably quick, like less than a second, EXCEPT the last instance when it goes back to the beginning and finds the first instance again. That instance can take over ten seconds.
Any idea why that might be?
Let me know if you need more info about the code.
I tried to just "Find" after the current iteration, instead of find next, and it has the same slow down.
VBA Lookup Using the Find Method
This is just the basic idea. There are many flaws e.g. if you cancel the input box, if you select a 'wrong' worksheet (e.g. column header not found), if there are error values, blank cells, etc.
Option Explicit
Sub ISN_Flyer_Performance()
' Flyer
Dim fws As Worksheet: Set fws = ActiveSheet ' improve!
Dim fLR As Long: fLR = fws.Range("A" & fws.Rows.Count).End(xlUp).Row
Dim frg As Range
Set frg = fws.Range(fws.Cells(2, "A"), fws.Cells(fLR, "A"))
'Debug.Print fws.Name, fLR, frg.Address
' Qlikview
Dim qws As Worksheet: Set qws = Application.InputBox( _
"Click any cell on the Qlikview Sheet you want to lookup against", _
"Find Qlikview Sheet", Type:=8).Worksheet
Dim qLR As Long: qLR = qws.Range("A" & qws.Rows.Count).End(xlUp).Row
Dim qC As Long
With qws.Rows(1) ' assuming that "Item Number" is surely in the first row
qC = .Find("Item Number", .Cells(.Cells.Count), _
xlFormulas, xlWhole).Column
End With
Dim qrg As Range
Set qrg = qws.Range(qws.Cells(2, qC), qws.Cells(qLR, qC))
'Debug.Print qws.Name, qLR, qC, frg.Address
Application.ScreenUpdating = False
Dim fCell As Range
Dim qCell As Range
Dim qFirstAddress As String
Dim TotalSales As Double
' Loop.
For Each fCell In frg.Cells
Set qCell = qrg.Find(fCell.Value, qrg.Cells(qrg.Cells.Count), _
xlFormulas, xlWhole)
If qCell Is Nothing Then
fCell.Offset(0, 2).Value = 0
Else
qFirstAddress = qCell.Address
Do
TotalSales = TotalSales + qCell.Offset(0, 5).Value
Set qCell = qrg.FindNext(qCell)
Loop Until qCell.Address = qFirstAddress
fCell.Offset(0, 2).Value = TotalSales
TotalSales = 0
End If
Next fCell
Application.ScreenUpdating = True
MsgBox "Lookup done.", vbInformation
End Sub
After doing more digging, someone suggested that the issue was that one of my sheets was a table. It had filters on the header row. I removed those (and conditional formatting on a row to find duplicates, and my code ran in a matter of seconds. After isolating those two, turns out the conditional formatting was the culprit.
I need help to remove character from a column with particular header.
I have a spreadsheet with headers (IP, hostname, Asset Group). I need to remove the first 3 characters from each row of the column called "Asset Group" (excluding header name (row 1)). Basically, I want to get rid of the "VM " from that column. I have a problem how to refer to that particular column "Asset Group". Thank you in advance!
Dim SelRange As Range
Dim ColNum As Integer
Dim CWS As Worksheet
'Find the column number where the column header is Asset Group
Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("Asset Group", CWS.Rows(1), 0)
LastColumn = Cells(1, CWS.Columns.Count).End(xlToLeft).Column
For i = 2 To LastColumn
...
Next i
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can try something like the following
Dim CWS As Worksheet
Dim AssetHdr as Range
Dim tmp as Variant
Dim i as Long
Set CWS = ActiveSheet
' Find Header Column
Set AssetHdr = CWS.Rows(1).Find(what:="Asset Group")
' Test if Header was found
If Not AssetHdr is Nothing Then
With CWS
' Get Last Row in Column
NoRow = .Cells(.Rows.Count, AssetHdr.Column).End(xlUp).Row
' Store in array
tmp = Application.Transpose(.Range(.Cells(2, AssetHdr.Column), .Cells(NoRow, AssetHdr.Column))).Value2
' Remove first 3 characters
For i = LBound(tmp) to UBound(tmp)
tmp(i) = Right(tmp(i), Len(tmp(i))-3)
Next i
' Write back to sheet
.Cells(2, AssetHdr.Column).Resize(ubound(tmp)-1).Value2 = tmp
End With
End If
Replace Partial Strings in a Range
Application.Match allows you to test its result with IsError or IsNumeric, while WorksheetFunction.Match raises an error if no match.
With the Range.Replace method you can replace values in a range in one go.
Option Explicit
Sub ReplacePartialString()
Dim cws As Worksheet: Set cws = ActiveSheet
Dim ColNum As Variant
ColNum = Application.Match("Asset Group", cws.Rows(1), 0)
If IsError(ColNum) Then
MsgBox "Column 'Asset Group' not found.", vbCritical
Exit Sub
End If
Dim LastCell As Range
Set LastCell = cws.Cells(cws.Rows.Count, ColNum).End(xlUp)
If LastCell.Row < 2 Then
MsgBox "No data found.", vbCritical
Exit Sub
End If
Dim crg As Range: Set crg = cws.Range(cws.Cells(2, ColNum), LastCell)
crg.Replace "VM ", "", xlPart, , True
End Sub
I was able to figure it out how to do it, the way I started. Thanks for the answer #VBasic2008, you created a better one with catching errors.
Dim CWS As Worksheet
Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("Asset Group", CWS.Rows(1), 0)
With CWS
LR = .Cells(.Rows.Count, ColNum).End(xlUp).Row
End With
For i = 2 To LR
CWS.Cells(i, ColNum) = Right(CWS.Cells(i, ColNum).Value, Len(CWS.Cells(i, ColNum).Value) - 3)
Next i
I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.
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.
I am working on a macro that loops over a the used range in one sheet (which is the last sheet in the workbook) in a certain column ("H"). The macro should then copy the value, only if it is not 0, and paste it in a sheet called "Overview" in the original row, offset by 3 (e.g. first row becomes 4th row) and in the column behind the last used column in row 5. (I hope that makes sense?). I already worked on some code but I did not manage to reference the last used column correctly and am honestly close to a breakdown.
can someone explain to me what I am doing wrong?
This is what I already have:
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, "A").End(xlRight).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```
The Subtle Differences in Ways of Finding the 'Last Column'
To successfully test the first procedure, in a new worksheet you have to:
write a value in cell A1,
write ="" in cell B1,
write a value in cell C1,
hide column C
and use a fill color in cell D1.
The result of the test will be shown in the Immediate window CTRL+G.
The third procedure is an example of how to use the second procedure, the function for calculating the column of the last non-blank cell in a row using the Find method.
The Code
Option Explicit
Sub LastColumnSuptileDifferences()
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
' Cell Value Comment
' A1: 1 Value
' B1: ="" Formula
' C1 1 Value: Hidden Column
' D1: Fill Color
Debug.Print ws.Rows(1).Find("*", , xlFormulas, , , xlPrevious).Column ' 3
Debug.Print ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 2
Debug.Print ws.Rows(1).Find("*", , xlValues, , , xlPrevious).Column ' 1
Debug.Print ws.Rows(1).CurrentRegion.Columns.Count ' 3
Debug.Print ws.Rows(1).SpecialCells(xlCellTypeLastCell).Column ' 4
Debug.Print ws.UsedRange.Rows(1).Columns.Count ' 4
End Sub
' This will find the last column even if columns are hidden
' unless you set 'excludeEmpties' to 'True'.
' If you set 'excludeEmpties' to 'True', the right-most cells in the row,
' possibly containing a formula that evaluates to "", will be skipped.
' Additionally only the visible cells will be included, i.e. hidden
' right-most columns, possibly containing data in cells of the row,
' will not be considered (mimicking 'End(xlToLeft)' or CRTL+Left).
Function getLastColumnInRow(RowNumber As Variant, _
Optional Sheet As Worksheet = Nothing, _
Optional excludeEmpties As Boolean = False)
If Sheet Is Nothing Then
Set Sheet = ActiveSheet
End If
Dim FormVal As XlFindLookIn
If excludeEmpties Then
FormVal = xlValues
Else
FormVal = xlFormulas
End If
Dim rng As Range
Set rng = Sheet.Rows(RowNumber).Find(What:="*", _
LookIn:=FormVal, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
getLastColumnInRow = rng.Column
Else
getLastColumnInRow = 0
End If
End Function
Sub testgetLastColumnInRow()
'...
LastColumn1 = getLastColumnInRow(5, wsDestination)
If LastColumn1 = 0 Then
MsgBox "No Data.", vbExclamation, "Empty Row"
Exit Sub ' or whatever
End If
' Continue with code.
Debug.Print LastColumn1
'...
End Sub
So you didn't quite get the last column right. Here's it back.
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, columns.count).End(xltoleft).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```