I am writing a macro that creates variable worksheets based on a value on an existing worksheet. I managed that part fine, but now I need to add a VLOOKUP formula on another sheet that references the newly created sheets. There is no set pattern to the name of the new worksheets, so I having trouble referencing them. Here is the code I used to create the new worksheets:
Dim ws As Worksheet
Dim rngCriteria As Range
Dim sName As String
Dim I As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Part Type REC")
If .AutoFilterMode = True Then .AutoFilterMode = False
.Range("D1:D" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("J1"), Unique:=True
Set rngCriteria = .Range("J1").CurrentRegion
For I = 2 To .Cells(Rows.Count, "J").End(xlUp).Row
sName = .Cells(I, "J")
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = sName
.Range("D1:D" & LastRow).AutoFilter Field:=1, Criteria1:="=" & .Cells(I, "J").Value
.Range("A1:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A1")
Next I
.AutoFilterMode = False
End With
Sheets("Part Type REC").Select
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select
And here is the VLOOKUP that I need to reference the new worksheets:
Sheets("TP Parts").Select
Range("O2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'ws.name'!C[-14],1,FALSE)"
Range("O2").Select
Where am I going wrong with this?
Thanks in advance!
Try this (UNTESTED - Just typed it here)
Range("O2").FormulaR1C1 = "=VLOOKUP(RC[-1]," & ws.name & "!C[-14],1,FALSE)"
Related
This is my first time asking a question on here. I have dug through similar questions, but have had no luck yet in resolving this quandary. I appreciate any help you can give me.
In the data set I am working with, I am looking to delete any rows that contain the word "Bench" in column R. I already have the rest of the worksheet running and have the Lrow value set as the last row.
I was first successful using the .Setfilter, selecting the range, and using EntireRow.Delete. But this ended up deleting the entire dataset if there were no rows to select.
To summarize the ask: Looking in Range("R2":"R" & Lrow), find all cells containing the text "Bench", then Delete the row.
Thank you!
Here is the entire VBA as sits right now (this bit is near the bottom):
Sub BE_Time_to_Fill()
'
' BE_Time_to_Fill Macro
'
Dim StartCell As Range
Dim RangeName As String
Dim myValue As Variant
Set StartCell = Range("A1")
myValue = InputBox("Enter Date: YY-MMM")
'Select Range
StartCell.CurrentRegion.Select
RangeName = "Dataset"
Dim LRow As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
LRow = Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("J:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").FormulaR1C1 = "Time to Fill"
Range("J2", "J" & LRow).FormulaR1C1 = "=RC[1]+RC[2]"
Range("F1").Select
Range("F1").FormulaR1C1 = "Job Code"
Range("F1", "F" & LRow).AutoFilter 1, ""
Range("F2", "F" & LRow).FormulaR1C1 = "=RC[-1]"
[F1].AutoFilter
Range("M1").FormulaR1C1 = "Source Time"
Columns("N:N").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("N1").FormulaR1C1 = "Cycle Time"
Range("N2", "N" & LRow).FormulaR1C1 = "=IMSUB(RC[1],RC[-1])"
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "Application ID"
Range("A2", "A" & LRow).FormulaR1C1 = "=CONCATENATE(RC[1],RC[4])"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "Timeframe"
Range("B2", "B" & LRow).Value = myValue
Dim rng As Range
Dim DelRng As Range
Set DelRng = Range("R2:R" & LRow)
For Each rng In DelRng
If rng.Value = "*Bench" Then
rng.EntireRow.Delete
ElseIf rng.Value <> "*Bench" Then
End If
Next
Range("G:H,M:N").Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Without seeing what code you have we can't help update it. But from your question the below might help.
If you're using a loop you'll need to include what to do if the set conditions aren't met. See example:
Sub example()
Dim rng As Range, DelRng As Range
Dim LastRow As Long
LRow = Range("R" & Rows.Count).End(xlUp).Row 'test for last filled row in column R
Set DelRng = Range("R1:R" & LRow) 'sets your range
For Each rng In DelRng
'change this value to match whatever you want to find. make sure this is entered as ALL CAPS and without spaces
If UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) = "GEM/BENCH" Then
rng.EntireRow.Delete
ElseIf UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) <> "GEM/BENCH" Then 'if loop can't find anything it will just exit
End If
Next
End Sub
I'm running into an issue where I'm unable to copy only visible cells to a new sheet. I'm able to get the lastrow, but I get #N/A on every cell except the first for each column. I want to just copy the visible cells. I'd also like to only put information on visible rows too, if possible?
Please see my code below:
Sub Importe()
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
Range("A1:A" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Value
Range("B1:B" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Value
End With
End Sub
Something like .Value2 = .Value doesn't work on special cells of type visible, because …
… e.g. if lastRow = 50 and there are hiddenRows = 10 then …
your source Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible)
has lastRow - hiddenRows = 40 rows
but your destination Range("A1:A" & lastRow).Value2
has lastRow = 50 rows.
On the first you subtract the visible rows, so they are different in size. Therefore .Value2 = .Value doesn't work, because you cannot fill 50 rows with only 40 source rows.
But what you can do is Copy and SpecialPaste
Option Explicit
Sub Importe()
Dim lastRow As Long
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("B1").PasteSpecial xlPasteValues
End With
End Sub
Nevertheless I recommend to avoid ActiveSheet or ActiveWorkbook if this is possible and reference a workbook eg by ThisWorkbook. My suggestion:
Option Explicit
Sub Importe()
Dim SourceWs As Worksheet
Set SourceWs = ThisWorkbook.Worksheets("Sheet1")
Dim DestinationWs As Worksheet
Set DestinationWs = ThisWorkbook.Worksheets.Add
Dim lastRow As Long
lastRow = SourceWs.Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
SourceWs.Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("A1").PasteSpecial xlPasteValues
SourceWs.Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("B1").PasteSpecial xlPasteValues
End Sub
To define whether a cell is visible or not, both its column and row should be visible. This means, that the .Hidden property of the column and the row should be set to False.
Here is some sample code of how to copy only the visible ranges between two worksheets.
Imagine that you have an input like this in Worksheets(1):
Then you manually hide column B and you want to get in Worksheets(2) every cell from the Range(A1:C4), without the ones in column B. Like this:
To do this, you should check each cell in the range, whether its column or row is visible or not.
A possible solution is this one:
Sub TestMe()
Dim myCell As Range
For Each myCell In Worksheets(1).Range("A1:C4")
If (Not Rows(myCell.Row).Hidden) And (Not Columns(myCell.Column).Hidden) Then
Dim newCell As Range
Set newCell = Worksheets(2).Cells(myCell.Row, myCell.Column)
newCell.Value2 = myCell.Value2
End If
Next myCell
End Sub
Just a general advise - whenever you use something like this Range("A1").Value2 = Range("A1").Value2 make sure that both are the same and not the left is Value2 and the right is .Value. It probably will not bring what you are expecting.
You cannot perform a direct value transfer without cycling though the areas of the SpecialCells(xlCellTypeVisible) collection.
Sometimes it is easier to copy everything and get rid of what you don't want.
Sub Importe()
Dim lr As Long
Worksheets("Sheet1").Copy after:=Worksheets("Sheet1")
With ActiveSheet
.Name = "xyz"
.Cells(1, 1).CurrentRegion = .Cells(1, 1).CurrentRegion.Value2
For lr = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
If .Cells(lr, "A").EntireRow.Hidden Then
.Cells(lr, "A").EntireRow.Delete
End If
Next lr
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(1, 1).CurrentRegion.Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 7).Value2
.Cells(1, 1).CurrentRegion.Offset(0, 1).Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 4).Value2
.Columns("C:XFD").EntireColumn.Delete
End With
End Sub
just to throw in an alternative version:
Sub Importe()
Dim sht1Rng As Range, sht1VisibleRng As Range
With Worksheets("Sheet1")
Set sht1Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
Set sht1VisibleRng = sht1Rng.SpecialCells(xlCellTypeVisible)
With Worksheets.Add
.Range("A1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 7).Value2
.Range("B1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 4).Value2
.UsedRange.EntireRow.Hidden = True
.Range(sht1VisibleRng.Address(False, False)).EntireRow.Hidden = False
End With
End Sub
which may have the drawback of Address() maximum "capacity "
I am a military recruiter and am trying to use autofilter to filter out a range from another range. I got this from another stackoverflow page but can not figure out how to change that string strSearch to a range like 123#gmail, 234#gmail, 345#gmail, etc.
We get lists of leads but I'd like to keep the running list of opt-outs and have VBA double check and delete any cells that have a value from the opt-out worksheet. I am pretty new to VBA but really enjoy it. Thank you!
I'd like it to be strSearch = Sheets("Opt-Outs").Range("A:A") so that it takes all values in A:A and uses them as an autofilter. I believe it needs to be a string array but am lost as how to get there. Please help.
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
This should do it...
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
Dim v() As Variant
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
v = Application.Transpose(Sheets("Opt-Outs").Range("A:A"))
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:=v
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As Variant
Dim i As Integer
i = 1
Sheets("Opt-Outs").Select
Range("H2").Value = "Ready"
Range("A2").Select
Do While Range("H2").Value <> Empty
Sheets("Opt-Outs").Select
Range("A2").Select
Cells(i + 1, 1).Copy
i = i + 1
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("H2").Value = IsBlank Then
Sheets("Email Addresses").Select
Exit Sub
Else
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("H2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Loop
I have written the below code. I have 3 worksheets: Dashboard, Workings and Data. I have a data validation list on worksheet(Dashboard) which has a long list of companies.
I want to be able to select a company from the list, press a button and then match from a company list in the worksheet data which has plenty of other columns for corresponding data for that company. I want to be able to take certain data from the company chosen and paste it into the next available row in worksheet (Workings). The list in the worksheet (data) has multiple entries for the same company, hence why I have added a loop in here.
This code does no give an error but does not give any result.
Can someone please tell me where I'm going wrong
Many thanks.
Sub pull_data()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled
CompanyListLocation = Worksheets("Dashboard").Cells(2, 4).Value
'Company = Worksheets("Data").Cells(CompanyListLocation, 1).Value
For x = 2 To 1000000
If Worksheets("Data").Cells(x, 5).Value = CompanyListLocation Then
Worksheets("Data").Cells(x, 5).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Data").Cells(x, 14).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Data").Cells(x, 15).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next x
End Sub
Are you trying to copy all the data from Data Sheet in column A of Workings Sheet?
You may try something like below. Tweak it if required.
Sub CopyData()
Dim wsCriteria As Worksheet, wsData As Worksheet, wsDest As Worksheet
Dim CompanyListLocation
Dim lr As Long, dlr As Long
Application.ScreenUpdating = False
Set wsCriteria = Sheets("Dashboard")
Set wsData = Sheets("Data")
Set wsDest = Sheets("Workings")
CompanyListLocation = wsCriteria.Range("D2").Value
lr = wsData.UsedRange.Rows.Count
dlr = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsData.AutoFilterMode = False
With wsData.Rows(1)
.AutoFilter field:=5, Criteria1:=CompanyListLocation
If wsData.Range("E1:E" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
wsData.Range("E2:E" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
wsData.Range("N2:N" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
wsData.Range("O2:O" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
If you want to copy values only, change the copy paste code to this...
If wsData.Range("E1:E" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
wsData.Range("E2:E" & lr).SpecialCells(xlCellTypeVisible).Copy
wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
wsData.Range("N2:N" & lr).SpecialCells(xlCellTypeVisible).Copy
wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
wsData.Range("O2:O" & lr).SpecialCells(xlCellTypeVisible).Copy
wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
End If
What this does now is take whats inputted Columns A:E and add whatever you list in column F, at the end of it, keeping A:E constant. This makes it much easier rather than copying and pasting but i want to add another row so that A:F is constant, switching the list to column G.
For ex, once it's outputted,
A1,B1,C1,D1,E1,F1
A1,B1,C1,D1,E1,F2
A1,B1,C1,D1,E1,F3
etc.
I just want to add another column to make it
A1,B1,C1,D1,E1,F1,G1
A1,B1,C1,D1,E1,F1,G2
A1,B1,C1,D1,E1,F1,G3
This is what I have so far.
Dim LastRowIput As String
With Sheets("Input")
LastRowInput = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
For I = 2 To LastRowInput
Dim LastRowLoc As String
With Sheets("Output")
LastRowLoc = .Cells(.Rows.Count, "F").End(xlUp).Row + 1
End With
Sheets("Input").Select
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Output").Select
Range("F" & LastRowLoc).Select
ActiveSheet.Paste
Sheets("Input").Select
Range("A" & I & ":" & "E" & I).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Output").Select
Dim LastRow As String
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Range("A" & LastRow).Select
ActiveSheet.Paste
Dim LastRowLoc2 As String
With Sheets("Output")
LastRowLoc2 = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
Application.CutCopyMode = False
Range("A" & LastRow & ":" & "E" & LastRowLoc2).Select
Selection.FillDown
Sheets("Input").Select
Next I
It seems that you want to copy the rows from A:G from Input to Output, expanding A:F in Output for every row in G.
Dim i As Long, lastRowInput As Long, nextRowOutput As Long
Dim wso As Worksheet
Set wso = Worksheets("Output")
With Sheets("Input")
lastRowInput = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRowInput
nextRowOutput = wso.Cells(.Rows.Count, "G").End(xlUp).Row + 1
.Range(.Cells(2, "G"), .Cells(2, "G").End(xlDown)).Copy _
Destination:=wso.Cells(nextRowOutput, "G")
.Range("A" & i & ":" & "F" & i).Copy _
Destination:=wso.Range(wso.Cells(nextRowOutput, "A"), _
wso.Cells(wso.Cells(.Rows.Count, "G").End(xlUp).Row, "F"))
Next i
End With
I've removed all methods involving the Range .Select and Range .Activate methods in favor of direct referencing.
Sample data from Input worksheet
Sample results from Output worksheet