Related
I have the following formula:
=IF(IFERROR(MATCH($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$A$49,0),0),VLOOKUP($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$B$49,2,FALSE),0)
In A1 I have another date: 10.10.2016
How can I replace only the date that is in the file name from the formula?
Until now, I've been using this:
Sub modify()
Dim a As Range
Set a = Range("a1")
[e3:e4].Replace "dones 05.10.2016.xls", ("dones " & a & ".xls"), xlPart
End Sub
The problem that in A2 I have another date and F3:F4 must have the date from A2, and so on until A300. How can I replace only the date of the file name in the formula?
The names of the files are standard: dones dd.mm.yyyy.xls
Sub modify()
Dim c As Range, r As Range
Set c = [a1]
Set r = [e3:e4]
Application.DisplayAlerts = False ' optional to hide dialogs
While c > ""
Debug.Print c.Address(0, 0), r.Address(0, 0) ' optional to check the address
r.Replace "[dones ??.??.????.xls]", "[dones " & c & ".xls]", xlPart
Set c = c.Offset(1, 0) ' A1 to A2
Set r = r.Offset(0, 1) ' E3:E4 to F3:F4
Wend
Application.DisplayAlerts = True
End Sub
Replace with wildcards:
[e3:e4].Replace "[dones ??.??.????.xls]", "[dones " & [a1] & ".xls]", xlPart
? matches any single character and * can be used to match 0 or more characters:
[e3:e4].Replace "[*.xls*]", "[dones " & [a1] & ".xls]", xlPart
https://www.ablebits.com/office-addins-blog/2015/09/29/using-excel-find-replace/#find-replace-wildcards
Instead of hard-coding "dones 05.10.2016.xls", you'll have to build that string from the cell values. Also, you'll need some looping logic to track which row you're reading from and which column you're writing to.
Assuming a date read in row 1 goes in column 5, a date read in row 2 goes in column 6, and so on, something like this should be good enough:
Dim targetColumn As Long
Dim sourceRow As Long
With ActiveSheet
For sourceRow = 1 To WhateverTheLastRowIs
targetColumn = 4 + sourceRow 'column 5 / "E" for sourceRow 1
Dim sourceDateValue As Variant
sourceDateValue = .Cells(sourceRow, 1).Value
Debug.Assert VarType(sourceDateValue) = vbDate
Dim formattedSourceDate As String
formattedSourceDate = Format(sourceDateValue.Value, "MM.DD.YYYY")
'replace string in rows 3 & 4 of targetColumn:
.Range(.Cells(3, targetColumn), .Cells(4, targetColumn) _
.Replace "[*.xls]", "[dones " & formattedSourceDate & ".xls]", xlPart
Next
End With
My understanding of the requirements is this:
There is a List of Dates in Column A starting at Row 1
A formula needs to be entered in rows 3:4 starting in Column E and moving one column to the right for each value in the List of Dates, i.e. Formula in column E has date from row 1, column F has date from row 2, …
This is the formula, in which the date 05.10.2016 in the filename '\\share\done\[dones 05.10.2016.xls]done should be update with corresponding value from the List of Dates as per point 2.
=IF(
IFERROR(MATCH($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$A$49,0),0),
VLOOKUP($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$B$49,2,FALSE),0)
This solution assumes the dates in column A are already formated as required by the filename link.
This solution uses a variable to hold the Link Formula and another variable to update the Link Formula with each Value in the List of Dates.
Also to simplify the update\replacement of the date let’s change the original date in the formula for 05.10.2016 for an unique key such as #DATE
Dim sFmlLink As String, sFml As String
sFmlLink = "=IF(" & Chr(10) & _
"IFERROR(MATCH($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,0),0)," & Chr(10) & _
"VLOOKUP($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,2,FALSE),0)"
Then we set a Range with the List of Dates and loop trough it to update and enter the formula as per point 2.
Sub FormulaLink()
Dim sFmlLink As String, sFml As String
sFmlLink = "=IF(" & Chr(10) & _
"IFERROR(MATCH($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,0),0)," & Chr(10) & _
"VLOOKUP($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,2,FALSE),0)"
Dim rDates As Range, lRow As Long, iCol As Integer
Rem Set Start Column
iCol = 5
With ThisWorkbook.Sheets("DATA")
Rem Set Dates List Range
Set rDates = Range(.Cells(1), .Cells(Rows.Count, 1).End(xlUp))
Rem Enter Link Formula in Rows 3:4, starting at Column 5
Rem and moving one column to the right for each Date in Column A
For lRow = 1 To rDates.Rows.Count
Rem Refresh Link Formula with Date from Column A
sFml = Replace(sFmlLink, "#DATE", rDates.Cells(lRow).Value)
Rem Enter Formula in Column iCol Rows 3:4
.Cells(3, iCol).Resize(2).Formula = sFml
Rem Move One Column to the right
iCol = 1 + iCol
Next: End With
End Sub
You will need to work with the string functions InStr and Mid here. Maybe this can help you:
Dim str As String
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim intLastPos As Integer
'Formula as string
str = "\\share\done\[dones 05-10-2016.xls]done'!$A$2:$A$49,0),0),VLOOKUP($C3,'\\share\done\[dones 05-10-2016.xls]done"
'Get the start and the End Position of the First Excel File
intPos1 = InStr(1, str, "[dones") - 1
intPos2 = InStr(1, str, ".xls") + 5
'Save the Last Postion for the second Replacement
intLastPos = intPos2
'Replace old File with [dones 01-10-1911.xls]
str = Mid(str, 1, intPos1) & "[dones 01-10-1911.xls]" & Mid(str, intPos2, Len(str))
'Get the start and the End Position of the second Excel File
intPos1 = InStr(intLastPos, str, "[dones")
intPos2 = InStr(intLastPos, str, ".xls")
'Replace the second File with [dones 01-10-1911.xls]
str = Mid(str, 1, intPos1) & "[dones 01-10-1911.xls]" & Mid(str, intPos2, Len(str))
After that you can read back the formula.
I'm quite new at VBA. I've used it in excel for a couple macros, but this one is way above my head.
I'm looking to create a macro that will find the appropriate column, then based on the value in this columns, changes the values in three other columns. I already have a static macro:
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range("AE" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AE" & i).Value) Then
If Range("AE" & i).Value = "No" And Range("U" & i).Value = "MEM" Then
Range("U" & i).Value = "C-MEM"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
ElseIf Range("AE" & i).Value = "No" And Range("U" & i).Value = "VCH" Then
Range("U" & i).Value = "C-VCH"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
End If
End If
Next i
End Sub
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces. What I want is, for instance, to look for column with "Role" header in row A3 and to insert it where the macro looks for column "U". That way other users can add/delete columns but I won't have to modify the macro every time.
In other macros, I manage to have this thing working:
Function fnColumnNumberToLetter(ByVal ColumnNumber As Integer)
fnColumnNumberToLetter = Replace(Replace(Cells(1,ColumnNumber).Address, "1", ""), "$", "")
End Function
Dim rngColumn As Range
Dim ColNumber As Integer
Dim ColName As String
ColName = "Email Address"
Sheets("Tracking").Select
Set rngColumn = Range("3:3").Find(ColName)
ColNumber = Sheets("Tracking").Range(rngColumn, rngColumn).Column
Sheets("Combined").Range(ActiveCell, "W2").FormulaLocal = "=IF(ISERROR(INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0))), INDEX(Tracking!$A:$A,MATCH(U:U,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)), INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)))"
However, I am unable to link the latter to the first and much less to get it to find multiple columns. Any help is appreciated.
EDIT:
Following suggestions, here is the new code. Doesn't return an error, but doesn't do anything either. It loops through the c loop ok, but jumps from For i =2 ... line to End Sub.
Sub Adjust()
Dim lastrow As Long
Dim i As Long
Dim headers As Dictionary
Dim c As Long
Set headers = New Scripting.Dictionary
For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
headers.Add Cells(3, c).Value, c
Next c
lastrow = Cells(headers.Item("Survey: Interest to Participate") & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Cells(i, headers.Item("Survey: Interest to Participate")).Value) Then
If Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "MEM" Then
Cells(i, headers.Item("Role")).Value = "C-MEM"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
ElseIf Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "VCH" Then
Cells(i, headers.Item("Role")).Value = "C-VCH"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
End If
End If
Next i
End Sub
The way I'd go about this would be to create a Dictionary with header names as keys and column numbers as values:
Dim headers As Dictionary
Set headers = New Scripting.Dictionary
Dim c As Long
'Assuming headers are in row 1 for sake of example...
For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
headers.Add Cells(1, c).Value, c
Next
Then, instead of using hard-code column letters with the Range, use the Cells collection and index it by column number using the Dictionary to look it up based on the header. For example, if your code expects column "U" to be under that header "Role" here:
Range("U" & i).Value = "C-MEM"
You can replace it with a column lookup like this using the Dictionary like this:
Cells(i, headers.Item("Role")).Value = "C-MEM"
Note that this requires a reference to the Microsoft Scripting Runtime (Tools->References... then check the box).
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces.
Protect the workbook to prevent this undesired behavior?
I would personally prefer to use Named Ranges, which will adjust with insertions and re-sorting of the data columns.
From Formulas ribbon, define a new name:
Then, confirm that you can move, insert, etc., with a simple procedure like:
Const ROLE As String = "Role"
Sub foo()
Dim rng As Range
Set rng = Range(ROLE)
' This will display $B$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Offset(0, -1).Insert Shift:=xlToRight
' This will display $C$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Cut
Application.GoTo Range("A100")
ActiveSheet.Paste
' This will display $A$100
MsgBox rng.Address, vbInformation, ROLE & " located:"
End Sub
So, I would define a Named Range for each of your columns (presently assumed to be AE, U, Y & AJ). The Named Range can span the entire column, which will minimize changes to the rest of your code.
Given 4 named ranges like:
Role, representing column U:U
RevProfile, representing column AJ:AJ
FollowUp, representing column Y:Y
Intent, representing column AE:AE
(NOTE: If you anticipate that users may insert rows above your header rows, then I would change the Named range assignments to only the header cells, e.g., "$AE$1", "$U$1", etc. -- this should require no additional changes to the code below)
You could do like this:
'Constant strings representing named ranges in this worksheet
Public Const ROLE As String = "Role"
Public Const REVPROFILE As String = "RevProfile"
Public Const FOLLOWUP As String = "FollowUp"
Public Const INTENT As String = "Intent"
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range(INTENT).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range(INTENT).Cells(i).Value) Then
If Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "MEM" Then
Range(ROLE).Cells(i).Value = "C-MEM"
Range(FOLLOWUP).ClearContents
Range(REVPROFILE).Cells(i).Value = "N/A"
ElseIf Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "VCH" Then
Range(ROLE).Cells(i).Value = "C-VCH"
Range(FOLLOWUP).Cells(i).ClearContents
Range(REVPROFILE).Value = "N/A"
End If
End If
Next
End Sub
I would go with David Zemens answer but you could also use Range().Find to get the correct columns.
Here I refactored you code to find and set references to your column headers. Everything is based relative to these references.
Here I set a reference to Row 3 of the Survey column where your column header is:
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
Because everything is relative to rSurvey the last row is = the actual last row - rSurvey's row
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
Since rSurvey is a range we know that rSurvey.Cells(1, 1) is our column header. What isn't apparent is that since rSurvey is a range rSurvey(1, 1) is also our column header and since column and row indices are optional rSurvey(1) is also the column header cell.
Know all of that we can iterate over the cells in each column like this
For i = 2 To lastrow
rSurvey( i )
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
Dim rRev As Range 'AJ
Dim rRole As Range 'U
Dim rFollowUp As Range 'Y
Dim rSurvey As Range 'AE
With Worksheets("Tracking")
Set rRev = .Rows(3).Find(What:="REV", MatchCase:=False, Lookat:=xlWhole)
Set rRole = .Rows(3).Find(What:="Role", MatchCase:=False, Lookat:=xlWhole)
Set rFollowUp = .Rows(3).Find(What:="Follow-up", MatchCase:=False, Lookat:=xlWhole)
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
End With
For i = 2 To lastrow
If Not IsError(rSurvey(i).value) Then
If rSurvey(i).value = "No" And rRole(i).value = "MEM" Then
rRole(i).value = "C-MEM"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
ElseIf rSurvey(i).value = "No" And rRole(i).value = "VCH" Then
rRole(i).value = "C-VCH"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
End If
End If
Next i
End Sub
I'm trying to make a function to do the following:
Cycle through all my datasets in my sheet
Cycle through each column in my datasets
Look at the title for that column and check if it is in my list.
Find find a few various other columns, but this time using .Find
Now cycle through each row in the column for that specific dataset
Use the column references found in point 4 and the row from point 5 to put the cell's into a variable that will be used on step 7 which is to insert a formatted comment in the originally found column (for that row).
I've tried getting some code working from what I found on a different site but I can't get it working correct, I'm stuck at part 5.
A data example could look like:
My attempted code looks like:
Sub ComTest()
COMLIST = ";Cond;"
Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each a In rng.SpecialCells(xlCellTypeConstants).Areas
With a.CurrentRegion
Set r = .Rows(1)
For j = 1 To r.Columns.Count
TitleCell = r.Cells(j).Address
v = ";" & Range(TitleCell).Value & ";"
'-----------------------------------------------------------------------------------------
If InStr(1, COMLIST, v) Then
On Error Resume Next
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Condw = r.Columns.Find(Replace(v, ";", "") & " " & "w", lookAt:=xlWhole).Column
Condw = .Cells(r, Condw).Address
' Add more stuff here
End If
'-----------------------------------------------------------------------------------------
Next j
End With
Next a
End Sub
As for part 7, the output would essentially be as follows for "row 1" but this part I should be able to do, it's the looping part that I am struggling with.
This question raises a few points that this answer might resolve for you and others in the future:
I note that not many of your previous questions have accepted answers, and that several of them present answers but you have needed to respond by saying it doesn't suit your needs for a certain reason. It suggests you aren't really providing the right details in your question. I think that's the case here. Perhaps you could outline the outcome you are trying to achieve and, especially for Excel VBA, the precise structure of your spreadsheet data. It's tempting to think in this question that you simply want to know how to take the values of Columns C to F and write them to a comment in Column B for any row that contains data.
Using web code can often take more time to understand and adapt than learning the code syntax from first principles. Your provided code is difficult to follow and some parts seem odd. I wonder, for example, what this snippet is meant to do:
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Using Option Explicit at the top of your module (which forces you to declare your variables) makes VBA coding and debugging much easier, and code submitted on SO is easier to follow if we can see what data types you meant variables to hold.
If your question is merely "How do I take the values of Columns C to F and write them to the cell in Column B for any row that contains data?", then your code could be as simple as:
Dim condCol As Range
Dim cell As Range
Dim line1 As String
Dim line2 As String
Dim cmt As Comment
'Define the "Cond" column range
'Note: this is an unreliable method but we'll use it here for the sake of brevity
Set condCol = ThisWorkbook.Worksheets("Sheet1").UsedRange.Columns("B")
'Delete any comment boxes
condCol.ClearComments
'Loop through the cells in the column and process the data if it's a number
For Each cell In condCol.Rows
If Not IsEmpty(cell.Value) And IsNumeric(cell.Value) Then
'Acquire the comment data
line1 = "Cond: " & cell.Offset(, 1).Value & "/" & cell.Offset(, 2).Value & _
" (" & Format(cell.Offset(, 3), "0.00%") & ")"
line2 = "Cond pl: $" & cell.Offset(, 4).Value
Set cmt = cell.AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
End If
Next
If, on the other hand, your question is that you have unreliable data on your spreadsheet and your only certainty is that the headings exist on any one row, then some form of search routine must be added. In that case your code could look like this:
Dim rng As Range
Dim rowRng As Range
Dim cell As Range
Dim condCol(0 To 4) As Long
Dim line1 As String
Dim line2 As String
Dim allHdgsFound As Boolean
Dim i As Integer
Dim cmt As Comment
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange
rng.ClearComments
For Each rowRng In rng.Rows
If Not allHdgsFound Then
'If we haven't found the headings,
'loop through the row cells to try and find them
For Each cell In rowRng.Cells
Select Case cell.Value
Case Is = "Cond": condCol(0) = cell.Column
Case Is = "Cond w": condCol(1) = cell.Column
Case Is = "Cond r": condCol(2) = cell.Column
Case Is = "Cond %": condCol(3) = cell.Column
Case Is = "Cond wpl": condCol(4) = cell.Column
End Select
Next
'Check if we have all the headings
'by verifying the condCol array has no 0s
allHdgsFound = True
For i = 0 To 4
If condCol(i) = 0 Then
allHdgsFound = False
Exit For
End If
Next
Else
If Not IsEmpty(rowRng.Cells(1).Value) Then
'The cell has values so populate the comment strings
line1 = "Cond: " & rowRng.Columns(condCol(1)).Value & "/" & _
rowRng.Columns(condCol(2)).Value & _
" (" & Format(rowRng.Columns(condCol(3)).Value, "0.00%") & ")"
line2 = "Cond pl: $" & rowRng.Columns(condCol(4))
Set cmt = rowRng.Columns(condCol(0)).AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
Else
'We've reached a blank cell so re-set the found values
allHdgsFound = False
Erase condCol
End If
End If
Next
Of course your data might be structured in any number of other ways, but we don't know that. My point is that if you can be more specific in your question and provide an outcome you are trying to achieve, you are likely to receive answers that are more useful to you.
I am new at Excel VBA and despite my efforts I cannot seem to find a similar example online to use as a solution to my issue.
I am creating a table of data related to an inventory of automobiles. The workbook that I have set up has two tabs. The first is labeled "FEEDER", and contains a table of hardcoded inputs (automobile values). The second is labeled "Sheet1" and contains raw data for all inventory. Sheet 1 requires automobile values in column "I". My goal is to set the workbook up so that a Column I labeled "Values" within "Sheet1", would be autopopulated with the click of a button from value inputs from the FEEDER sheet. The tricky part (for me) is that the values are based on 1) the automobile type (i.e. sedan/ pickup/ etc.), 2) the color (different colors have slightly different values), and 3) the Manufacture year. I was approaching this at first like an IF AND statement, but thought creating a macro would be a more efficient route to take.
I have a working list, but many more automobile types to go (400+ total). If I could get a some help at thsi stage I can [hopefully] figure out the rest.
Your help would be greatly appreciated.
Screen Shots here: FEEDER Table and SHEET1 Inventory List
My code:
Sub ValueFill()
Dim x As Integer
For x = 3 To Range("A" & Rows.Count).End(xlUp).Row
If UCase(Sheets("Sheet1").Range("A" & x).Text) = "Pickup*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Red*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("C" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Pickup*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Blue*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("D" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Sedan*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Red*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("E" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
ElseIf UCase(Sheets("Sheet1").Range("A" & x).Text) = "Sedan*" And UCase(Sheets("Sheet1").Text("C" & x).Value) = "Blue*" Then
Range("I" & x).Formula = Application.WorksheetFunction.Index(Sheets("FEEDER").Range("F" & Rows.Count).End(xlUp).Row, Application.WorksheetFunction.Match(Sheets("Sheet1").Range("f" & x), Sheets("Feeder").Range("b" & Rows.Count).End(xlUp).Row, 0), 1)
'I would keep "ElseIf-ing" for each combination of auto type and color, then index match by year...
Else: Range("I" & x).Text = "Error"
End If
Next
End Sub
My knee-jerk reaction is to use two different functions, since color and type are interdependent: one for handling the year and one for handling the type and color of the vehicle. Something like
Sub ValueFill()
For car = 1 to last 'this is your loop over the cars in Sheet1
color = type_color(car)
year = get_year(car)
price = Sheets("FEEDER").Cells(year, color).value
Function get_year(car)
'gets the year value for a give car and returns the corresponding row
number of that year, i.e car year 2009 is row 10 in FEEDER
End Function
Function type_color()
'will first get the type then convert based on color
'gets the type of the car and returns the left column index for that type
'i.e. type = pickup then column index = 3 (Column C)
if color not same as column value from above then
offset it
'i.e. for a blue pickup column index + 1 -> 4
end function
Here is a partial rewrite of your sample code. It isn't enough to finalize the module but perhaps it can get you started.
Sub ValueFill()
Dim x As Long, wsf As Worksheet, app As Application
Set app = Application
Set wsf = Sheets("FEEDER")
With Sheets("Sheet1")
For x = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
Select Case Left(LCase(.Cells(x, 1).Text), 5)
Case "picku"
Select Case Left(LCase(.Cells(x, 3).Text), 3)
Case "red"
'unclear on whether you want a value or a formula - pick one of these
.Range("I" & x).Value = app.Index(wsf.Columns(3), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
'.Range("I" & x).Formula = "=INDEX(Feeder!C:C, MATCH(F" & x & ", Feeder!B:B, 0))"
'.Range("I" & x).FormulaR1C1 = "=INDEX(Feeder!C3, MATCH(RC6, Feeder!C2, 0))"
Case "blu"
.Range("I" & x).Value = app.Index(wsf.Columns(4), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case Else
'do nothing
End Select
Case "sedan"
Select Case Left(LCase(.Cells(x, 3).Text), 3)
Case "red"
.Range("I" & x).Value = app.Index(wsf.Columns(5), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case "blu"
.Range("I" & x).Value = app.Index(wsf.Columns(6), app.Match(.Cells(x, 6).Value, wsf.Columns(2), 0))
Case Else
'do nothing
End Select
Case Else
Debug.Print "not it"
End Select
Next x
End With
Set wsf = Nothing
Set app = Nothing
End Sub
If more information about the nature of the FEEDER worksheet was provided, a one-size-fits-all formula may be able to be developed.
Actually, I am not familiar with excel functions. But, I can do it with vba code only.
Thanks, this is very good question. Try it with my idea.
Here, my approach for your problem. You don't need anything to modify. Just copy and run. It work well.
Public Sub fillValue()
Dim inventorySheet, priceSheet As Worksheet
Dim inventoryRow, priceRow As Integer
Dim redPickup, bluePickup, redSedan, blueSedan, redRoadster, blueRoadster As String
Dim automobileType, automobileColor, automobilePrice As String
Dim isFound As Boolean
'Set sheet for common use.
Set inventorySheet = ThisWorkbook.Worksheets("Sheet1")
Set priceSheet = ThisWorkbook.Worksheets("FEEDER")
'Price list in FEEDER sheet are stable.
'So, we can use them as constant.
'I initialize them as follow. You can add more column.
redPickup = "C"
bluePickup = "D"
redSedan = "E"
blueSedan = "F"
redRoadster = "G"
blueRoadster = "H"
'Set the start row Sheet1 sheet
inventoryRow = 3
'Looping all data from "Sheet1" sheet.
'One thing that the main colum is Automobile Type. So, loop until it is blank.
Do While inventorySheet.Range("A" & inventoryRow) <> ""
'First, get the price row from FEEDER sheet for manufacture year.
'Reset flag.
isFound = False
'Set the start row of FEEDER sheet.
priceRow = 4
'Loop manufacture year column of FEEDER sheet until blank
Do While priceSheet.Range("B" & priceRow) <> ""
If priceSheet.Range("B" & priceRow) = inventorySheet.Range("F" & inventoryRow) Then
'Set true for exist record for manufacture year
isFound = True
'Exit loop
Exit Do
End If
priceRow = priceRow + 1
Loop
'If there is no record for price, we should not do anything.
'If price record for manufacture year is exist, take the price.
If isFound Then
'Second, getting the automobile type from Sheet1.
'Get Automobile Type from sheet
automobileType = inventorySheet.Range("A" & inventoryRow)
'Split by space
splitedValues = Split(Trim(automobileType), " ")
'Get last word for automobile type
automobileType = splitedValues(UBound(splitedValues))
'Third, get the automobile color.
'Get Automobile Color from sheet.
automobileColor = inventorySheet.Range("C" & inventoryRow)
'Split by "-"
splitedValues = Split(Trim(automobileColor), "-")
'Get first word for automobile type
automobileColor = splitedValues(LBound(splitedValues))
'Reset automobile price.
automobilePrice = ""
'Fouth, check type and color and get price
Select Case automobileType
Case "Roadster"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redRoadster & priceRow)
Else
automobilePrice = priceSheet.Range(blueRoadster & priceRow)
End If
Case "Sedan"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redSedan & priceRow)
Else
automobilePrice = priceSheet.Range(blueSedan & priceRow)
End If
Case "Pickup"
If automobileColor = "Red" Then
automobilePrice = priceSheet.Range(redPickup & priceRow)
Else
automobilePrice = priceSheet.Range(bluePickup & priceRow)
End If
End Select
'Fifth, set the price in inventory sheet.
inventorySheet.Range("I" & inventoryRow) = automobilePrice
Else
'Set error for miss.
inventorySheet.Range("I" & inventoryRow) = "Error"
End If
'Increase inventory row
inventoryRow = inventoryRow + 1
Loop
End Sub
Here, my evidence for your problem.
My prepare data for "Sheet1" sheet.
My prepare data for "FEEDER" sheet.
After running code, I got this result.
Have a nice job..!
I want to fill in 2..N integer series into filtered/visible range.
This code fills in the series but ignores the filtered range:
COL_SID_CURRENT = 3
COL_SID_CURRENT_STR = "c"
ROW_LAST = ActiveSheet.UsedRange.Rows.Count
' Start the series with value 2 in cell "c2"
Cells(2, COL_SID_CURRENT).FormulaR1C1 = "2"
aRangeStr = "" & COL_SID_CURRENT_STR & "2" ' -> "c2"
Range(aRangeStr).Select
aRangeStr = aRangeStr & ":" & COL_SID_CURRENT_STR & ROW_LAST ' -> "c2:c24"
Selection.AutoFill Destination:=Range(aRangeStr),Type:=xlFillSeries
I've tried to add the xlCellTypeVisible into the code but none of my combinations worked:
Range(aRangeStr).SpecialCells(xlCellTypeVisible).Select
Selection.AutoFill Destination:=Range(aRangeStr).SpecialCells(xlCellTypeVisible), _
Type:=xlFillSeries
Any hint how to fill the series only on filtered/visible cells?
Autofill doesn't work on the filtered range but there is alternative. :)
TRIED AND TESTED
You can use this formula instead (I am assuming you are filtering on the basis of what is stored in Col A (See Sample Image)
I am adding + 1 as you are starting the series with value 2 in cell "c2"
=IF(A2="FILTER_TEXT",COUNTIF($A$2:A2,"FILTER_TEXT")+1,"")
And to adapt it to your example, use this code.
Sub Sample()
COL_SID_CURRENT = 3
COL_SID_CURRENT_STR = "c"
ROW_LAST = ActiveSheet.UsedRange.Rows.Count
' Start the series with value 2 in cell "c2"
Cells(2, COL_SID_CURRENT).Formula = "=IF(A2=""FILTER_TEXT"",COUNTIF($A$2:A2,""FILTER_TEXT"")+1,"""")"
aRangeStr = "" & COL_SID_CURRENT_STR & "2" ' -> "c2"
aRangeStr = aRangeStr & ":" & COL_SID_CURRENT_STR & ROW_LAST ' -> "c2:c24"
Range(aRangeStr).Formula = "=IF(A2=""FILTER_TEXT"",COUNTIF($A$2:A2,""FILTER_TEXT"")+1,"""")"
End Sub
Please change "FILTER_TEXT" to the relevant text. Also you might need to change the Reference Range. Like I mentioned, I am assuming that the filter is based on Values in Col A.