I am working on a project in which I am comparing column D with column C of sheet("Backend") and the difference is shown in column E (in %). I'd like to highlight the % difference (column E) in RED color, where the difference is less than -10.00% and greater than 10.00%. Then would like to copy those items from column B corresponding each highlighted cell and paste it in sheet("UPDATER") beneath cell A7.
Attached is the screenshot for your reference
Sub check_date()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 13).End(xlUp).Row
wsData.Range("M8:M" & lRow).Interior.ColorIndex = xlNone
wsData.Range("M8:M" & lRow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(M8>=EOMONTH(TODAY(),-2)+1,M8<EOMONTH(TODAY(),-1))"
wsData.Range("M8:M" & lRow).FormatConditions(wsData.Range("M8:M" & lRow).FormatConditions.Count).SetFirstPriority
With wsData.Range("M8:M" & lRow).FormatConditions(1).Interior
.Color = RGB(255, 255, 0)
.TintAndShade = 0
End With
wsData.Range("M8:M" & lRow).FormatConditions(1).StopIfTrue = False
Range("M8").Select
End Sub
Here's what I got. It's a bit of a drastic change but I'm hoping this is actually what you're going for.
Sub formatcondition()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer, My_Range As Range, i As Integer, iRow As Integer, cell As Variant, RowNum As Long, lRowUpdater As Long
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 5).End(xlUp).Row
lRowUpdater = wsData.Cells(Rows.Count, 1).End(xlUp).Row
RowNum = 8 'setting the first row in the UPDATER sheet
Datasht.Range("E1:E" & lRow).Interior.ColorIndex = xlNone 'Reset the color before running
wsData.Range("A8:D" & lRowUpdater + 8).ClearContents 'clear your updater sheet. Remove if not needed.
For i = 1 To lRow
On Error GoTo Continue
If Datasht.Range("E" & i).Value < -0.1 Or Datasht.Range("E" & i).Value > 0.1 Then 'If greater than or less than
Datasht.Range("E" & i).Interior.ColorIndex = 6 'Change the color of affected cells if you need that
wsData.Range(wsData.Cells(RowNum, 1), wsData.Cells(RowNum, 4)).Value = _
Datasht.Range(Datasht.Cells(i, 2), Datasht.Cells(i, 5)).Value 'straight copy the values from the cells as it loops rather than using copy/paste
wsData.Range(wsData.Cells(RowNum, 2), wsData.Cells(RowNum, 4)).NumberFormat = "0.00%" 'change the number format of outputted cells to percentages (if needed)
RowNum = RowNum + 1 'move to the next row in the output
End If
Continue:
Resume Nexti
Nexti:
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
EDIT:
For the date to add a year my version would be just adding to what I gave earlier. Instead we now add an AND function to contain the OR, then checking if the YEAR in the cell is the current year. If you're only wanting this year then we can also forgo the IF statement which was checking that if the current month was January it would incorporate December. But if thats not needed then:
=AND(OR(MONTH(NOW())=MONTH(M8),MONTH(NOW())-1=MONTH(M8)),YEAR(M8)=YEAR(NOW()))
Or
=AND(MONTH(M8)>=MONTH(NOW())-1,MONTH(M8)<MONTH(NOW())+1,YEAR(M8)=YEAR(NOW()))
Both the same length and do the same thing just in different way.
Related
I need to speed up this macro & to avoid specifying a range as (A2:A2000) for example because my data is dynamic.
My macro checks every cell with the same value in some columns to merge it
Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Cell As Range
' Merge Duplicated Cells
Application.DisplayAlerts = False
Sheets("1").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
CheckAgain:
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Sheets("2").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
ActiveWorkbook.Save
MsgBox "Report is ready"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
For a quick fix add
Application.Calculation = xlManual
after your code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
and
Application.Calculation = xlAutomatic
after your code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
and to improve the macro not processing blank ranges,
dim ws as worksheet
dim lastrowA, lastrowB, lastrow C as long
'Instead of setting last row to 2000, can use the actual last row by eg:
'find last row of data in column A'
lastrowA = ws.Cells(Rows.Count, 1).End(xlUp).Row
'find last row of data in column B'
lastrowB = ws.Cells(Rows.Count, 2).End(xlUp).Row
'find last row of data in column C'
lastrowC = ws.Cells(Rows.Count, 3).End(xlUp).Row
and insert these into the macro instead of 2000 eg:
Set myrange = Range("A2:A" & lastrowA & ,
The slowdown in your code is primarily due to the presence of the GoTo CheckAgain transition, due to which the cycle of processing the same cells is repeated many times. In addition, multiple calls to the cells of the sheet are used, which is very time consuming. In the code below, unnecessary cycles are excluded, reading data from the sheet, merging and formatting cells are performed immediately for the entire processed subrange.
I ran the code on 2 sheets with 10000 rows each, it took 2.6 sec.
Option Explicit
Sub test1()
'Here we indicate only the starting cells in each column, because
'the size of the non-empty area in these columns is calculated
'automatically in the MergeCells() procedure
MergeCells Sheets("1").Range("A2,B2,L2,M2,N2,O2")
MergeCells Sheets("2").Range("A2,B2,L2,M2,N2,O2")
End Sub
Sub MergeCells(myrange As Range)
Dim v As Variant, col As Range, Cell As Range, toMerge(0 To 1) As Range, k As Long, index As Byte, area As Variant, arr As Variant, skip As Boolean
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
For Each col In myrange
' next line reads all the data from sheet's column at once
arr = col.Resize(myrange.Parent.Cells(Rows.Count, col.Column).End(xlUp).Row - col.Row + 1)
For k = LBound(arr, 1) To UBound(arr, 1) - 1 'loop through all rows of an array
If Not skip And arr(k, 1) = arr(k + 1, 1) And Not IsEmpty(arr(k, 1)) Then
'to prevent "gluing" adjacent sub-ranges within the same range,
'two ranges are used in the toMerge array, all odd sub-ranges are collected
'in the element with index 0, all even ranges are collected in the element
'with index 1, and Index switches from 0 to 1 and vice versa after each array subrange
If toMerge(index) Is Nothing Then
Set toMerge(index) = col.Offset(k - col.Row + 1).Resize(2)
Else
Set toMerge(index) = Union(col.Offset(k - col.Row + 1).Resize(2), toMerge(index))
End If
index = 1 - index
skip = True ' if merged, skip next cell
Else
skip = False
End If
Next
' if the ranges for merge are non-empty, we merge and format simultaneously for all subranges
For Each area In toMerge
If Not area Is Nothing Then
area.Merge
area.VerticalAlignment = XlVAlign.xlVAlignCenter
End If
Next
Set toMerge(0) = Nothing
Set toMerge(1) = Nothing
Next
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
If I understand you correctly .... besides the already existing answer, another way (which is not meant to be better) maybe something like this :
Before and after running the sub (please ignore the yellow fill and the border, as it is used just to be easier to see the result) like image below :
===>
Sub test()
Dim LR As Integer: Dim cnt As Integer
Dim i As Integer: Dim c As Range
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
LR = .Rows(.Rows.Count).Row
cnt = .Columns.Count
End With
For i = 1 To cnt
Set c = Cells(1, i)
Do
If c.Value <> "" And c.Value = c.Offset(1, 0).Value _
Then Range(c, c.Offset(1, 0)).Merge _
Else Set c = c.Offset(1, 0)
Loop Until c.Row > LR
Next
End Sub
LR is the last row of the used range of the active sheet.
cnt is the column count of the used range of the active sheet.
Then it loop from 1 to as many as the cnt as i variable.
Inside this loop, it create the starting cell as c variable, then do the inner loop, by checking each c within the looped column (the i in cnt) if the row below c has the same value then it merge this c and the c.offset(1,0). The inner loop stop when the c.row is larger than the LR, then it goes to the next i (the next column).
Please note, the data should start from column A ... because the outer loop assume that the column to be in the inner loop will start from column 1 (column A). And also, the code doesn't do any fancy things, such as alignment, font size, border, etc.
I am using below code in one workbook as the following:
(1) Match a range on SheetA against a range on SheetB.
(2) If the data found on SheetB, then some values will be inserted on SheetB and Sheet Log.
(3) The matched data (rows) on SheetB will be copied to Sheet Result and Autofit.
(4) The matched data (rows) on SheetB will be cleared. (cut & paste is not applicable).
The count of values on the first range in SheetA is normally 7 or 8 and this macro was as fast as it takes 2 seconds to finish all that steps.
I tried to put 146 values on the first range, but the macro turned to be very slow and it took 35 seconds to finish.
Please, how to speed up and optimize this macro?
Note: there is no problem at all to change match code or copy, paste, autofit and clear code.
Link for the full macro and sheet on the first comment.
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
Please, check the next adapted code. It uses arrays for faster iteration and for faster results return. Also, setting the row height for each cell consumes Excel resources. I commented some rows but no time now for everything. If something unclear, please do not hesitate to ask for clarifications:
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k + 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
Dim rngClearCont As Range
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k + 1
If rngClearCont Is Nothing Then
Set rngClearCont = StatusColumn.Cells(i) 'set the range necessary to clear rows at the end
Else
Set rngClearCont = Union(rngClearCont, StatusColumn.Cells(i))
End If
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
rngClearCont.EntireRow.ClearContents
End If
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
It should take less than a second...
The root of your issue is that you are making many edits to the worksheet. One of the first ways to speed up VBA code is to reduce the number of times you write data to the sheet.
Rather than writing your data to the sheet every time in a For Each loop, add all of your data to an Array and then write that entire Array to the sheet(s) at once. This way, you don't have to write multiple times for every For Each loop, but only once.
I cannot guarantee that this is the only reason your code is "sub-optimal" but it's a good place to start to improve performance times.
While writing to the sheet does take time, the main problem here is the copy/paste part.
If you, after the row
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
Put something like:
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
And then remove the copy/paste part completely, you should be able to run it almost instantly.
I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?
As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.
For information, the values in Column B and C are formatted as text and the values in G are formatted as date.
Before
and this is basically what I wish for.
After
I have modified code appropriately as per your requirement in the comment.
Sub Change_Text_Color()
Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer
LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)
Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)
For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
CharLen = Len(Cell_in_Col_G.Text)
Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
If Not Find_Text Is Nothing Then
StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
End With
End If
Next
Next
End Sub
Please let me know your feedback on it.
Use Characters:
With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With
colours the first four letters black and the next ten in red.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.characters
I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:
Sub MarkDatesInCells()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
' Turn off updating
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Clear autofilter if exists
If .AutoFilterMode Then .AutoFilterMode = False
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
.UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
.AutoFilterMode = False
Next
Next
End With
' Turn on updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT
Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (i.e. the text that is highlight)
Sub MarkDatesInCellsInATable()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb") '<- Change to the table name
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Reset autofilter
oTable.Range.AutoFilter
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
oTable.Range.AutoFilter
Next
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Here is the code that I am using
Sub insert_column_every_other()
Dim colx As Long
Dim H As Worksheet
Set H = Sheets("Sheet1") 'Replace H3 with the sheet that contains your data
For colx = 9 To 1200 Step 2
Call H.Columns(colx).Insert(Shift:=xlToRight)
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
Next colx
End Sub
Getting an error in the following line,
H.Range(H.Cells(2, colx), H.Cells(21, colx)).FormulaR1C1 = "=
((OFFSET(RC[-1])-(OFFSET(RC[-3]))/(OFFSET(RC[-3]))*SQRT(252))"
The error is Application-defined error.
The macro will create a column after the 9th column till the 500th column and then in the blank column will calculate the percentage difference of the stock price of two consecutive days so that's why I went with that particular offset formula.
I think this is what you are looking for
Option Explicit
Sub insert_column_every_other()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 9 To 1200 Step 2
ws.Columns(i).Insert
ws.Range(ws.Cells(2, i), ws.Cells(21, i)).Formula = "=(" & ws.Cells(2, i - 1).Address(False, False) & "-" & ws.Cells(2, i - 2).Address(False, False) & ")/(" & ws.Cells(2, i - 2).Address(False, False) & ")*SQRT(252)"
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I've written some code that assigns each item in a list a code based on row #. What I want to do from there is choose a copy all information from each row that corresponds with a chosen code, then paste it to another workbook. I've been having some trouble. Here's the code:
Sub LSHP_Distribute()
Dim wbLSHP As Workbook
Dim wsLSHP As Worksheet
Dim CodeRange As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim wbTEST As Workbook
Set wbLSHP = ActiveWorkbook
Set wsLSHP = wbLSHP.Sheets("Sheet1")
'Generate codes for newly added items
Application.ScreenUpdating = False
'Turn off screen updating
With wsLSHP
FirstRow = .Range("F3").End(xlDown).Row + 1
LastRow = .Range("B6", .Range("B6").End(xlDown)).Rows.Count + 5
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
End With
For Each cell In CodeRange
If cell = "" Then
If cell.Row Mod 3 = 0 Then
cell.Value = "1"
ElseIf cell.Row Mod 3 = 1 Then
cell.Value = "2"
ElseIf cell.Row Mod 3 = 2 Then
cell.Value = "3"
Else
End If
End If
Next cell
'Open Spreadsheets to Distribute Items
Dim PasteRow As Long
Dim i As Integer
Set wbTEST = Workbooks.Open(Filename:="V:\Test.xlsx")
PasteRow = wbTEST.Sheets("Sheet1").Range("B6").End(xlDown).Row + 1
Below is where I'm having the problem
wbLSHP.Activate
For Each cell In CodeRange
If cell = "1" Then
Range(ActiveCell.Offset(0, -5), ActiveCell.Offset(0, 20)).Select
Selection.Copy
wbTEST.Sheets("Sheet1").Cells(PasteRow, 1).PasteSpecial xlPasteValues
PasteRow = PasteRow + 1
Else
End If
Next cell
End Sub
First problem is the For loop isn't copying the correct range in "CodeRange", the second problem is it only copies once before I get an Automation Error. Let me know if you have any questions, or know of a more efficient way to write this code.
Thanks so much for your time!
Your range is defined to Start in F3 and end in BSomething, but you store to CodeRange only the F column.
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
Try using:
Set CodeRange = .Range("$B$" & FirstRow, "$F$" & LastRow)
I suggest instead of Copy and Paste, assign the value to a variable and put the value of the variable on wbTEST.