I have the below code that copies a range from one sheet and pastes it in a differ sheet and does a calculation (ignores the colored values).
What I want to do is, I want to add additional cells into this code to perform the same function but for a slightly different formula...
The formula I ant to use is given below and the destiantion cells are AH 101 and AH102.
"=PERCENTILE.INC(" & Rng.Address(, , , True) & ",90%)*24"
"=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
This is my entire code:
Sub TPNoRed()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("A3:D30")
If cel.Font.Color = 0 Then
If Rng Is Nothing Then
Set Rng = cel
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("AH1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("AH1:AH" & Sheets("TP").Cells(Rows.count, "AH").End(xlUp).Row)
Sheets("WBR45").Range("AH103").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",99%)*24"
Sheets("WBR45").Range("AH103").Value = Sheets("WBR45").Range("AH103").Value
Sheets("TP").Columns("AH:AH").ClearContents
Application.ScreenUpdating = True
End Sub
Related
I have written a small code that allow me to:
in a defined range (xrng) in column F, find all the cells that contain certain text and once found, select all the cells in the range A:G on the same row and delete them. I have a reverse loop, which work partially, as ignores some cells in the range, specifically the 2nd and the 3rd. Below a before and after pic:
Here my code:
Sub removeapp()
Dim g As Long, xrng As Range, lastrow As Long, i As Long
i = 4
lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Set xrng = Range(Cells(lastrow, "F"), Cells(i, "F"))
For g = xrng.Count To i Step -1
If xrng.Cells(g).Value = "Adjustment" Or xrng.Cells(g).Value = "Approved" Then
Range(Cells(xrng.Cells(g).Row(), "A"), Cells(xrng.Cells(g).Row(), "G")).Delete
End If
Next
End Sub
Could you help me to figure out why?
Also, the code runs really slow... if you have any tip to make it slighlty faster would be great!
Try this, please:
Sub removeappOrig()
Dim xrng As Range, lastrow As Long, sh As Worksheet
Set sh = ActiveSheet 'good to put here your real sheet
lastrow = sh.Cells(sh.Rows.count, "F").End(xlUp).Row
Set xrng = sh.Range("A4:F" & lastrow)
xrng.AutoFilter field:=6, Criteria1:="=Adjustment", Operator:=xlOr, _
Criteria2:="=Approved", VisibleDropDown:=False
Application.DisplayAlerts = False
xrng.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
sh.AutoFilterMode = False
End Sub
The next code is also fast enough since it iterates between array elements (in memory), not deletes row by row (it creates a ranges Union) and delete all at once:
Private Sub remoRangesAtOnce()
Dim i As Long, lastRow As Long, sh As Worksheet
Dim arrF As Variant, rng As Range, rngDel As Range
Set sh = ActiveSheet 'please name it according to your sheet name
lastRow = sh.Cells(sh.Rows.count, "F").End(xlUp).Row
Set rng = sh.Range("F4:F" & lastRow)
arrF = rng.Value
For i = LBound(arrF) To UBound(arrF)
If arrF(i, 1) = "Adjustment" Or arrF(i, 1) = "Approved" Then
If rngDel Is Nothing Then
Set rngDel = sh.Range(sh.Range("A" & i + 3), sh.Range("F" & i + 3))
Else
Set rngDel = Union(rngDel, sh.Range(sh.Range("A" & i + 3), sh.Range("F" & i + 3)))
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.Delete xlShiftUp
End Sub
I have two worksheets, "Signed" and "April". I want to copy Column "Y" from "Signed" based on certain criteria into column "A" of "April" starting from the next available/blank row. ( so right under the existing data).
My criteria for column Y is that if column L = month of cell "D2" from "April" AND the year of cell "D2" from "ApriL"...( so right now D2 is 4/30/2017).. then copy that cell in the next available row of Col A of "April" and keep adding on.
I've been trying several different things but just am not able to get it..any idea on how I can achieve this?
My code is below:
Set sourceSht = ThisWorkbook.Worksheets("Signed")
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp))
Set ws2 = Sheets(NewSheet)
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each rw In myRange.Rows
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow)
End If
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim dtCheck As Date
Dim lCount As Long
Dim lResultIndex As Long
Dim i As Long
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1))
If lCount = 0 Then
MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro"
Exit Sub
Else
ReDim aResults(1 To lCount, 1 To 1)
aData = .Value
End If
End With
For i = 1 To UBound(aData, 1)
If IsDate(aData(i, 1)) Then
If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then
lResultIndex = lResultIndex + 1
aResults(lResultIndex, 1) = aData(i, UBound(aData, 2))
End If
End If
Next i
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults
End Sub
Alternate method using AutoFilter instead of iterating over an array:
Sub tgrFilter()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim dtCheck As Date
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
.AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy"))
Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub
Here's a generic script which you can easily modify to handle almost ANY criteria, as needed.
Sub Copy_If_Criteria_Met()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "X" Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I currently have some code that finds cells not in the first column and moves them over. I'm facing a problem with cells that start with "=". Can you guys think of any work-arounds to solve this problem. Thanks in Advance.
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Value <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Value
cel.Value = ""
End If
Next cel
End Sub
Either every time in your For each loop
If Cstr(cel.Value) <> "" And ... 'you need to do that for every cel.Value occurencies
Or declare a variable at the beginning
Dim StringInCell as String
For Each cel In rng
StringInCell=Cstr(cel.Value)
If StringInCell...
You may try .Text property as well (though I haven't had luck using that ever, I rather to use CStr).
This may work as well if the parsed data is throwing an error exception or something:
...
wk.Cells(cel.Row, 1).NumberFormat = "#"
wk.Cells(cel.Row, 1) = Cstr(cel.Value) 'related to the option chosen from above
Try this
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.HasFormula Then
wk.Cells(cel.Row, 1).Formula = cel.Formula
cel.ClearContents
Else
If cel.Value <> "" And cel.Column <> 1 Then
With wk.Cells(cel.Row, 1)
.NumberFormat = "#" '<<edit: added formatting
.Value = cel.Value
End with
cel.Value = ""
End If
End If
Next cel
End Sub
If you have cells that begin with =, but are not to be treated as formulas, but rather as Text, then using Sgdva's alternative suggestion:
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Text <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Text
cel.Value = ""
End If
Next cel
End Sub
EDIT#1:
This version should "de-formularise" a cell before moving it to column 1:
Sub Move2()
Dim cel As Range, rng As Range
Dim wk As Worksheet, s As String
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
s = cel.Text
If s <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1).Value = s
cel.Value = ""
End If
Next cel
End Sub
First my code:
Option Explicit
Sub UpdateCandidates()
Application.ScreenUpdating = False
Dim wks As Worksheet, wks2 As Worksheet
Dim Lastrow As String, Lastrow2 As String
Dim Rng As Range, i As Long, Rng2 As Range, i2 As Long
Dim cell As Variant, cell2 As Variant
Set wks = ThisWorkbook.Worksheets("Candidates")
Lastrow = wks.Range("B" & Rows.Count).End(xlUp).Row
If Lastrow > 1 Then
cell = wks.Range("B2:B" & Lastrow).Value
i = 1: Set Rng = Nothing
While i <= Lastrow
For i = i To Lastrow
Set wks2 = ThisWorkbook.Worksheets("Job live")
Lastrow2 = wks2.Range("A" & Rows.Count).End(xlUp).Row
If Lastrow2 > 1 Then
cell2 = wks2.Range("A2:A" & Lastrow2).Value
i2 = 1: Set Rng2 = Nothing
While i2 <= Lastrow2
For i2 = i2 To Lastrow2
If cell = cell2(i2, 1) Then
MsgBox ("found")
End If
Next
Wend
End If
Next
Wend
End If
Application.ScreenUpdating = True
End Sub
This basically works and compares the two columns but at the end it shows an error:
"Subscript out of range"
I don't understand why. I thought it's because of <= Lastrow but fixing to < Lastrow doesn't change anything.
I also would like to copy a value from the first sheet to the second one to a particular cell. And also insert a row below the cell from my second sheet.
I also don't understand why I have to compare cell to cell2(i2,1) and not cell to cell2. If I compare cell to cell2 it says type mismatch. And I have the same error if I enter a second value in my sheets.
What's wrong with my code?
I see your code, and here's a proposal
Option Explicit
Sub CompareDefinedRanges()
Dim rng1, rng2 As Range
Dim found As Boolean
Dim i, j, foundAt As Integer
Set rng1 = Worksheets("Candidates").Range("B2", Worksheets("candidates").Range("B2").End(xlDown).Address)
Set rng2 = Worksheets("Job live").Range("A2", Worksheets("Job Live").Range("A2").End(xlDown).Address)
'show items
For i = 1 To rng1.Rows.Count
found = False
foundAt = 0
For j = 1 To rng2.Rows.Count
If rng1.Item(i) = rng2.Item(j) Then
found = True
foundAt = j
End If
Next j
If found Then
MsgBox rng1.Item(i).Value & " found at " & CStr(foundAt), , "Candidates"
Else
MsgBox rng1.Item(i).Value & " not found", , "Candidates"
End If
Next i
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
I require assistance with the following please:
I need to filter a Range A9 - A32 for any data in column G.
Then i need to copy the data, but only columns A - E & G to sheet 2.
then delete the filtered data and return back to non filtered view.
I have tried the following without success:
Dim shSrc As Worksheet
Dim shDst As Worksheet
Dim rSrc As range
Dim rDst As range
Dim range
Dim numCol As Long ' number of columns to copy
On Error GoTo EH
range = ("A:E,G:G")
' select source and dest sheets
Set shSrc = ActiveWorkbook.Worksheets("Active Snag List")
Set shDst = ActiveWorkbook.Worksheets("Snag History")
' Select initial rows
Set rSrc = shSrc.Cells(9, 7)
Set rDst = shDst.Cells(2, 1)
' loop over source
Do While rSrc <> ""
' Test Source row, Qty = 0 and Name is not blank
With rSrc
If .Offset(0, 2) = 0 And .Value <> "" Then
'Copy
.Resize(1, range).Copy rDst.Resize(1, range)
Set rDst = rDst.Offset(1, 0)
End If
End With
Set rSrc = rSrc.Offset(1, 0)
Loop
Exit Sub
EH:
MsgBox "Error " & Err.Description
Thank you in advance!
To get your code working , replace the IF section with this
If .Offset(0, 2) = 0 And .Value <> "" Then
'Copy
'Cells A:E
rDst.Resize(1, 5).Value = .EntireRow.Cells(1, 1).Resize(1, 5).Value
' Cell G
rDst.Offset(0, 6).Value = .Value
Set rDst = rDst.Offset(1, 0)
End If
Why not use Autofilter rather than looping through cells? It will me much faster. See this example.
CODE(TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim shSrc As Worksheet, shDst As Worksheet
Dim rDst As range, rng As range, rngtocopy As range
Dim lastrow As Long
On Error GoTo EH
'~~> Select source and dest sheets
Set shSrc = ThisWorkbook.Worksheets("Active Snag List")
Set shDst = ThisWorkbook.Worksheets("Snag History")
'~~> Select initial rows
Set rDst = shDst.Cells(2, 1)
With shSrc
'~~> Remove any filters
.AutoFilterMode = False
'~~> Get the last row of Col G
lastrow = .range("G" & .Rows.Count).End(xlUp).Row
With .range("A8:G" & lastrow)
'~~> Filter G Col for non blanks
.AutoFilter Field:=7, Criteria1:="<>"
'~~> Get the offset(to exclude headers)
Set rng = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Remove Col F from the resulting range
Set rngtocopy = Union(shSrc.range(Replace(rng.Address, "G", "E")), _
shSrc.range(Replace(rng.Address, "A", "G")))
'~~> Copy cells to relevant destination
rngtocopy.Copy rDst
'~~> Delete the filtered results
rng.EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Exit Sub
EH:
MsgBox "Error " & Err.Description
End Sub
SNAPSHOTS
Sheet 1 before the macro runs
Sheet 2 after the macro runs
Sheet 1 after the macro runs