Inserting VBA formula into a defined Range - excel

I'm looping through a table (Sheet4) in a worksheet and inserting an empty column between each original column. In the new, empty columns, I want to insert a VLookup function.
I has successfully inserted the columns and I have successfully held the proper range (proper number of rows too) in a variable called FormulaRange.
I'm having problems with the VLookup. I don't know if it's the way I'm storing my variables or if I need to have a paste function after my Vlookup. Can someone take a look and give me a hand?
*note - I stored FormulaRange as String becuase As Range wouldn't let me pass my code into the variable. As a result I can't use the FormulaRange.Formula Method.
If I were to manually input the VLookup I would write it as =VLOOKUP(B1,RosettaStone_Employees!$A$1:$B$5,2,FALSE) and then copy down the range.
Sub InsertColumnsAndFormulasUntilEndOfProductivityTable()
Dim ActivityRange As Range
Dim UserName As String
Dim FormulaRange As String
Dim i As Integer
Dim x As Long
Dim y As Long
Dim Startrow As String
Dim Lastrow As String
Sheet6.Activate
Set ActivityRange = Range("A1", Range("B1").End(xlDown))
Sheet4.Activate
Range("A1").Select
y = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row - 1
x = (Sheet4.Cells(1, Columns.Count).End(xlToLeft).Column) * 2
For i = 1 + 2 To x Step 2
Columns(i).EntireColumn.Insert
Startrow = 2
Lastrow = y
UserName = Cells(1, i - 1)
FormulaRange = Cells(Startrow, i).Address & ":" & Cells(Lastrow + 1, i).Address
FormulaRange = "=VLookup(UserName, ActivityRange, 2, False)"
Next
End Sub
Thanks
Jonathan

I changed your code a little to get rid of the sheet activates. Also I changed a few things to ranges and included with blocks.
This is untested:
Sub InsertColumnsAndFormulasUntilEndOfProductivityTable()
Dim ActivityRange As Range
Dim UserName As String
Dim FormulaRange As Range
Dim i As Long
Dim x As Long
Dim y As Long
Dim Startrow As Long
Dim Lastrow As Long
With Sheet6
Set ActivityRange = .Range("A1", .Range("B1").End(xlDown))
End With
With Sheet4
y = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
x = (.Cells(1, .Columns.Count).End(xlToLeft).Column) * 2
For i = 1 + 2 To x Step 2
.Columns(i).EntireColumn.Insert
Startrow = 2
Lastrow = y
UserName = .Cells(1, i - 1)
Set FormulaRange = .Range(.Cells(Startrow, i), .Cells(Lastrow + 1, i))
FormulaRange.FormulaR1C1 = "=VLookup(R1C[-1],'" & ActivityRange.Parent.Name & "'!" & ActivityRange.Address(1, 1, xlR1C1) & ", 2, False)"
'If you do not want dynamic formulas and just want the value
'then comment out the above and use the below.
'FormulaRange.Value = Application.Vlookup(UserName,ActivityRange,2,False)
Next
End With
End Sub
The R1C1 is a relative nomenclature. When it fills the formulas into the columns it will return the cell relative to the one into which the formula will be filled.
For example, above I use R1C[-1]. This says get the first row of the column directly to the left. So if the formula was being entered into B2 it would return A$1.
The [] denotes the relative address. Without the [] eg R1C1 it would indicate an absolute address and would return $A$1. So R1C1:R4C2 would return a range of $A$1:$B$4.

Related

VBA VLOOKUP with dynamic range

I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next

Adding additional rows under a row, depending on the amount of used cells in a range

basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA

Excel VBA offset function

I have an Excel file with information in column A and column B. Since these columns could vary in the number of rows I would like to use the function offset so that I could print the formula in one time as an array rather than looping over the formula per cell (the dataset contains almost 1 million datapoints).
My code is actually working the way I want it to be I only can't figure out how to print the code in Range(D1:D5). The outcome is now printed in Range(D1:H1). Anybody familiar how to use this offset within a for statement?
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(0, i + 2).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
Using the Offset(Row, Column), you want to offset with the increment of row (i -1), and 3 columns to the right (from column "A" to column "D")
Try the modified code below:
Set example = Range("A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
One way of outputting the formula in one step, without looping, to the entire range, is to use the R1C1 notation:
Edit: Code modified to properly qualify worksheet references
Option Explicit
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set example = .Range(.Cells(1, 1), .Cells(LastRow, 1))
End With
example.Offset(columnoffset:=3).FormulaR1C1 = "=sum(rc[-3],rc[-2])"
End Sub
You don't need to use VBA for this. Simply type =sum(A1:B1) in cell D1 and then fill it down.
If you're going to use VBA anyway, use this:
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
The way offset works is with row offset, column offset. You want the column to always be fixed at 3 to the right.

Populate blank cells in a column until all populated from repeating list

I need to use VBA code to populate a list of filtered blank cells. I decided to make a picture with small example to explain it easier. Column D should be populated with names from col A repeating until each ID has a name.
I have absolutely no idea how to loop it to make it work - it's mind boggling! I have been searching the web for hours so I am now asking for help. Please note that column C and D are filtered with criteria blanks for column D.
Here is working code to populate blank cells of a filtered list with the same 3 names alternating.
Sub Macro1()
Dim last As Long
Dim counter As Integer
Dim nameRange As Range
Dim cell As Range
last = Range("A2").End(xlDown).Row
Set nameRange = Range("D2:D" & last).SpecialCells(xlCellTypeVisible)
counter = 1
For Each cell In nameRange
If counter = 1 Then
cell.Value = "Carrie"
counter = counter + 1
ElseIf counter = 2 Then
cell.Value = "Lisa"
counter = counter + 1
Else
cell.Value = "Bob"
counter = 1
End If
Next
End Sub
thanks for everyone's input - Hopefully, this will help someone else in the future.
This will do it without the need of filtering the data.
Sub foo()
Dim ws As Worksheet
Dim lastrowa As Long
Dim lastrowd As Long
Dim counta As Long
Dim rng As Range
counta = 2 'First row of name list in column A
Set ws = Sheets("Sheet1")
With ws
lastrowa = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowd = .Range("D" & .Rows.Count).End(xlUp).Row
For Each rng In .Range(.Cells(2, 5), .Cells(lastrowd, 5))
If rng.Value = "" Then
rng.Value = .Cells(counta, 1).Value
If counta = lastrowa Then
counta = 2
Else
counta = counta + 1
End If
End If
Next rng
End With
End Sub
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range("D2:D11")
If you don't know where column C ends that is easy enough to work out. Something like
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
If you don't know how far the data extends in column A:
Dim last As Integer
last = Range("A2").End(xlDown).Row
Range("D2:D" & last).Value = Range("A2:A" & last).Value
Range("D2:D" & last).AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
My example doesn't work perfectly, or even well... Its late :)
Create a named range that encapsulates all your "names" (called namesRange in my example).
In your "assigned" column put the following formula:
=INDEX(namesList,ROW()-((INT(ROW()/ROWS(namesList))*ROWS(namesList))),1)
Update...
Thought about it, and remembered how to excel a little more.. The following is what I was trying to do in my first example.
=INDEX(namesList,MOD(ROW()-1,ROWS(namesList)-1)+1,1)

Excel copy cell values X times with increasing numbers in the end

I have a similar task as in there:
Copy value N times in Excel
But mine is a bit more complex.
So, I have this kind of sheet:
A B
dog-1.txt 3
cat-1.txt 2
rat-1.txt 4
cow-1.txt 1
The final result needs to be the following:
A
dog-1.txt
dog-2.txt
dog-3.txt
cat-1.txt
cat-2.txt
rat-1.txt
rat-2.txt
rat-3.txt
rat-4.txt
cow-1.txt
As you see it doesn't only multiply the cell content X times taken from column B, but it also increases the number in file name the same number of times with 1 step increase.
How could I achieve that?
Try the following (tried and tested):
Sub Extend()
Dim Rng As Range, Cell As Range
Dim WS As Worksheet, NewCell As Range
Dim Dict As Object, NewStr As String
Set WS = ThisWorkbook.Sheets("Sheet1") 'Modify as necessary.
Set Rng = WS.Range("A1:A5") 'Modify as necessary.
Set Dict = CreateObject("Scripting.Dictionary")
For Each Cell In Rng
If Not Dict.Exists(Cell.Value) Then
Dict.Add Cell.Value, Cell.Offset(0, 1).Value
End If
Next Cell
Set NewCell = WS.Range("C1") 'Modify as necessary.
For Each Key In Dict
For Iter = 1 To CLng(Dict(Key))
NewStr = "-" & Iter & ".txt"
NewStr = Mid(Key, 1, InStrRev(Key, "-") - 1) & NewStr
NewCell.Value = NewStr
Set NewCell = NewCell.Offset(1, 0)
Next Iter
Next Key
End Sub
Screenshot (after running):
The logic here is to get each name from the first column, store it as a dictionary key, then get the value beside it and store that that as the key-value. We then iterate inside each of the dictionary's keys, where we use the key-value as the upperbound of the iteration. During each iteration, we modify the string to change its number to the "current digit" of the iteration.
We choose C1 as the initial target cell. Every iteration, we offset it one (1) row below to accommodate the new/next iteration.
Let us know if this helps.
Tested , is this what u wanted :) ? (Working fine in my system)
Sub teststs()
Dim erange As Range
Dim lrow As Integer
Dim cnt As Integer
Dim rnt As Integer
Dim str As String
Dim lrow2 As Integer
With ActiveSheet
lrow = .Range("A" & Rows.Count).End(xlUp).Row ' finding the last row
For Each erange In .Range("A1:A" & lrow) ' loop though each each cell in the A column
cnt = erange.Offset(0, 1).Value
rnt = Mid(erange.Value, InStr(erange.Value, "-") + 1, 1)
For i = 1 To cnt 'Looping to cnt times
With Sheets("Sheet2")
lrow2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
str = Replace(erange.Value, rnt, i, InStr(erange.Value, "-") + 1)
.Range("A" & lrow2).Value = Left(erange.Value, InStr(erange.Value, "-")) & str
End With
Next i
Next erange
End With
End Sub

Resources