I have created a method for defining range between two words and iterate through it to copy paste values from one worksheet to another. There is some strange reason it does not work.
I specify row, it is 18, my code starts from row 20? So it copies everything starting from row 20. O_o
It does not detect range correctly as it copies values below my words as well? I have checked that I don't have same words elsewhere.
Any suggestions?
Here is code for calling method:
Sub dsfdsfdsfds()
copyOptionsToTable 18, CalculationItemOM1
End Sub
Here is method:
Private Sub copyOptionsToTable(RowToPaste As Integer, OperatingWorksheet As Worksheet)
'Dim FirstWord, SecondWord
Dim OptionsRange As Range
Dim cell, x
'Set FirstWord = OperatingWorksheet.Range("W:W").Find("OPTIOONS START", LookIn:=xlValues, lookat:=xlWhole)
'Set SecondWord = OperatingWorksheet.Range("W:W").Find("OPTIOONS END", LookIn:=xlValues, lookat:=xlWhole)
Set OptionsRange = OperatingWorksheet.Range(OperatingWorksheet.Cells.Find("[OPTIOONS START]"), OperatingWorksheet.Cells.Find("[OPTIOONS END]"))
x = 0
' Copy - Paste process
For Each cell In OptionsRange
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste).Offset(0 + x, 0).Value = cell.Offset(0 + x, -20).Value
ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste).Offset(0 + x, 3).Value = cell.Offset(0 + x, 2).Value
End If
x = x + 1
Next cell
End Sub
Source sheet:
Output sheet:
EDIT:
Output still looks like this?
You're already incrementing cell by one row inside the loop - you don't need to further offset that using x
Set OptionsRange = OperatingWorksheet.Range( _
OperatingWorksheet.Cells.Find("[OPTIOONS START]").Offset(1,0), _
OperatingWorksheet.Cells.Find("[OPTIOONS END]").Offset(-1, 0))
x = 0
' Copy - Paste process
For Each cell In OptionsRange.Cells
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
With ThisWorkbook.Worksheets("TableForOL").Range("B" & RowToPaste)
.Offset(x, 0).Value = cell.Offset(0, -20).Value
.Offset(x, 3).Value = cell.Offset(0, 2).Value
End With
x = x + 1 '<< only increment if you copied values...
End If
Next cell
Also I'm not sure this line does what you intend?
If Not IsEmpty(cell.Value) Or cell.Value <> "OPT" Then
maybe
If Not IsEmpty(cell.Value) And cell.Value <> "OPT" Then
This is a silly question, but I can't seem to find the issue with the code after a lot of hunting. I'm creating a For Each loop that finds all incidences of "Friday," goes over to the cell 6 columns over from "Friday" (under the "Overtime" heading), inserts the number 0 in that cell, and changes the number format. Here is my worksheet so far.
Here is my code:
Sub Calendar_Generator()
Dim WS As Worksheet
Dim MyInput As String
Dim StartDay As Date
Dim Sp() As String
Dim a As Integer
Dim R As Long
Dim Match As Range
Dim b As Variant
Dim DayNames() As String
Dim FirstAddress As String
Dim DeleteDays As Range
Dim c As Variant
Dim Day1 As Range
Dim WorkDays As Range
Dim d As Variant
'Dim Fri As Range
Set WS = ActiveWorkbook.ActiveSheet
WS.Range("A1:R100").Clear
'This loop is crashing excel
'Do
MyInput = InputBox("Enter the start date for the Calendar:")
'If MyInput = "" Then Exit Sub
'Loop While Not IsDate(MyInput)
' repeat if entry isn't recognized as a date
' Set the date value of the beginning of inputted month.
' -- regardless of the day the user entered, even if missing
StartDay = DateSerial(Year(CDate(MyInput)), Month(CDate(MyInput)), 1)
'Set headers
Range("a1").Value = Format(StartDay, "mmmm") & " Time Sheet"
Sp = Split("Day,Date,Time In,Time Out,Hours,Notes,Overtime", ",")
For a = 0 To UBound(Sp)
WS.Cells(2, 1 + a).Value = Sp(a)
Next a
' fill the days for the selected month
' == the last day of a month is always the day before the first of the next
' here deducting 2 to count from 0
For R = 0 To Day(DateAdd("m", 1, StartDay) - 2)
With WS.Cells(3 + R, 2)
.Value = StartDay + R
.NumberFormat = "d-mmm"
.Offset(, -1).Value = StartDay + R
.Offset(, -1).NumberFormat = "dddd"
End With
Next R
ReDim DayNames(1)
'To add more headers, change statement to 3
DayNames(0) = "Saturday"
DayNames(1) = "Sunday"
For b = LBound(DayNames) To UBound(DayNames)
Set Match = WS.Cells.Find(What:=DayNames(b), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, _
MatchCase:=True, SearchFormat:=False)
If Not Match Is Nothing Then
FirstAddress = Match.Address
Do
Match.EntireRow.Clear
'Highlight cell containing table heading in green
Set Match = WS.Cells.FindNext(Match)
Loop While Not Match Is Nothing
End If
Next b
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Works for some reason if it's executed twice
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Insert and format template time values with formula for hours worked in E3
Set Day1 = Range("B3")
Range(Day1, Day1.End(xlDown)).Select
With Selection
Selection.Offset(, 1).Value = "8:00 AM"
Selection.Offset(, 1).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 2).Value = "4:00 PM"
Selection.Offset(, 2).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 3).Value = "0"
Selection.Offset(, 3).NumberFormat = "h:mm"
Day1.Offset(, 3).Formula = "=D3-C3"
End With
'Fill in hours worked formula
Day1.Offset(, 3).Select
Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown))
'*This is the loop that isn't functioning, but also isn't calling any errors*
'Set Overtime calculation
Set WorkDays = Range("A3:A33")
For Each d In WorkDays
If d = "Friday" Then
d.Offset(, 6).Value = "0"
d.Offset(, 6).NumberFormat = "h:mm"
End If
Next d
End Sub
I've had some trouble with loops crashing Excel since I switched to Excel 365, but this For Each loop isn't crashing it. Any ideas as to why this For Each loop isn't doing its job?
I have a workbook with multiple sheets, and new sheets will be added regularly, titled by [mmm yy] format. In my main sheet ("ContactList"), I have an IF formula with a 'nested' VLOOKUP formula in three columns to pull the respective numbers from the appropriate sheet, and I have a cell that has the date in the format I want. I want my script to look at the cell with the date in it, and use that cell's value to update the columns of VLOOKUP formulas to match that. For example, in February, the cell on my main sheet will say "Feb 20", so my VLOOKUP formulas will look in the sheet titled "Feb 20". In March, that cell will update, and I want my script (preferably automatically but tied to a button is alright) to update all the VLOOKUP functions to now be looking in the "Mar 20" sheet.
I feel like I've been trying a million things and keep getting various errors, but I'm just stuck now. My latest attempt was to set the parts of the formula as variables, then set other variables to be those parts parsed together.
Sub Update_Counts()
Dim rng As Range
Dim cellnum As Integer
Dim curr As Object
Dim v1 As String, v2 As String, v3 As String, v4 As String, v5a As String, v5b As String, v5c As String
Dim v6a As String, v6b As String, v6c As String, strFormC As String, strFormMR As String, strFormMD As String
v1 = "=IF(VLOOKUP("
v2 = Cells(cell.Row, "A")
v3 = ",'"
v4 = Cells(1, 6).Value
v5a = "'!B7:F50, 2, FALSE) = 0, 'EMPTY', VLOOKUP("
v5b = "'!B7:F50, 3, FALSE) = 0, 'EMPTY', VLOOKUP("
v5c = "'!B7:F50, 4, FALSE) = 0, 'EMPTY', VLOOKUP("
v6a = "'!B7:F50, 2, FALSE))"
v6b = "'!B7:F50, 3, FALSE))"
v6c = "'!B7:F50, 4, FALSE))"
strFormC = v1 & v2 & v3 & v4 & v5a & v2 & v3 & v4 & v6a
strFormMR = v1 & v2 & v3 & v4 & v5b & v2 & v3 & v4 & v6b
strFormMD = v1 & v2 & v3 & v4 & v5c & v2 & v3 & v4 & v6c
Set curr = Worksheets("ContactList").Cells(cellnum, 6)
Set rng = Sheets("ContactList").Range("F3:H55")
For cellnum = 3 To 55
If Cells(2, 6).Value = "Commercial Total" Then
curr.Value = strFormC
ElseIf Cells(2, 7).Value = "Medicare" Then
curr.Value = strFormMR
ElseIf Cells(2, 8).Value = "Medicaid" Then
curr.Value = strFormMD
End If
Next cellnum
End Sub
That's what I have thus far. I'm currently getting "Run-time error '424'; Object Required". I had thought having curr as an object would allow me to get through it, but I think my cellnum value is the "needs to be an object" portion of the For statement. However, I'm not sure how to get the cell values in there without how it's set up. I had tried a "For Each" loop but got a myriad of issues there as well. I wasn't able to find any examples of people wanting to update their cells' formulas by including a cell value, but perhaps I just wasn't looking in the right spot. Any advice is much appreciated!
As I put in my comment, you don't need to use VBA to achieve this.
If I'm reading your code correctly, I think you just need the following formula in cell A3 and copy it down:
=IF(VLOOKUP($A3,INDIRECT("'"&$F$1&"'!B7:F50"),IF($F$2="Commercial Total",2,IF($G$2="Medicare",3,IF($H$2="Medicaid",4,1))),FALSE)=0,"EMPTY",VLOOKUP($A3,INDIRECT("'"&$F$1&"'!B7:F50"),IF($F$2="Commercial Total",2,IF($G$2="Medicare",3,IF($H$2="Medicaid",4,1))),FALSE))
This is on the assumptions I've made from reading your code that:
Cell F1 contains the name of the sheet you want to get the data from.
One of Cells F2, G2 and H2 will contain the keywords Commercial Total, Medicare and Medicaid respectively.
If you want some code though, this is how I'd build the LOOKUP flexibly:
Sub Update_Counts()
Dim rng As Range
With Sheets("ContactList")
Set rng = .Range("F3:F55")
lookupformula = "=IF(VLOOKUP(A<rownum>,'<sheetname>'!B7:F50,<colnum>,FALSE)=0,""EMPTY"",VLOOKUP(A<rownum>,'<sheetname>'!B7:F50,<colnum>,FALSE))"
For Each c In rng.Cells
sheetname = .Cells(1, 6).Value
thisrow = c.Row
If .Cells(2, 6).Value = "Commercial Total" Then
colnum = 2
ElseIf .Cells(2, 7).Value = "Medicare" Then
colnum = 3
ElseIf .Cells(2, 8).Value = "Medicaid" Then
colnum = 4
End If
finalformula = Replace(Replace(Replace(lookupformula, "<rownum>", thisrow), "<sheetname>", sheetname), "<colnum>", colnum)
c.Formula = finalformula
Next
End With
End Sub
I figured it out from #CLR 's answer, thank you! I was struggling because I figured out the date value to stop the script from trying to import a new document, but the If/ElseIf criteria were getting a little muddied. Since the headers all always existed, it was inputting the last condition across the board, meaning I was getting column 3 data for all three columns. I am sure there's a neater way to do it, but at least for me, I'm happy with splitting the three functions and having a button run all three.
Private Sub CommandButton1_Click()
Update_Counts_COM
Update_Counts_MR
Update_Counts_MD
End Sub
Sub Update_Counts_COM()
Dim rng As Range
With Sheets("ContactList")
Set rng = .Range("F3:F21,F24:F27,F30:F51")
lookupformula = "=IFERROR(IF(VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)=0,""EMPTY"",VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)), ""Not Found"")"
For Each c In rng.Cells
sheetname = .Cells(1, 6).Value
thisrow = c.Row
If .Cells(2, 6).Value = "Commercial Total" Then
colnum = 2
End If
finalformula = Replace(Replace(Replace(lookupformula, "<rownum>", thisrow), "<sheetname>", sheetname), "<colnum>", colnum)
c.Formula = finalformula
Next
End With
End Sub
Sub Update_Counts_MR()
Dim rng As Range
With Sheets("ContactList")
Set rng = .Range("G3:G21,G24:G27,G30:G51")
lookupformula = "=IFERROR(IF(VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)=0,""EMPTY"",VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)), ""Not Found"")"
For Each c In rng.Cells
sheetname = .Cells(1, 6).Value
thisrow = c.Row
If .Cells(2, 7).Value = "Medicare" Then
colnum = 3
End If
finalformula = Replace(Replace(Replace(lookupformula, "<rownum>", thisrow), "<sheetname>", sheetname), "<colnum>", colnum)
c.Formula = finalformula
Next
End With
End Sub
Sub Update_Counts_MD()
Dim rng As Range
With Sheets("ContactList")
Set rng = .Range("H3:H21,H24:H27,H30:H51")
lookupformula = "=IFERROR(IF(VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)=0,""EMPTY"",VLOOKUP(A<rownum>,'<sheetname>'!B7:F59,<colnum>,FALSE)), ""Not Found"")"
For Each c In rng.Cells
sheetname = .Cells(1, 6).Value
thisrow = c.Row
If .Cells(2, 8).Value = "Medicaid" Then
colnum = 4
End If
finalformula = Replace(Replace(Replace(lookupformula, "<rownum>", thisrow), "<sheetname>", sheetname), "<colnum>", colnum)
c.Formula = finalformula
Next
End With
End Sub
was what ended up working for me! Thanks everyone :)
I have a simple problem for which I can't find a solution to. I can get values into a MsgBox in my code in Excel as for example: aaaaaaaa, bbbbbbbb, cccccccc, dddddddd etc. I would like to get the comma separated values from this MsgBox into cells starting from for example C15, C16, C17, C18 etc. as following:
C15: aaaaaaaa
C16: bbbbbbbb
C17: cccccccc
C18: dddddddd
C19: etc.
I can't find a solution to my problem although I have tried to Google an answer for a couple of hours. All help appreciated!
Sub ComSepList()
Dim lr As Long, rng As Range, c As Range, fLoc As Range
Dim fAdr As String, rngOut As Range
Dim xArr() As String
Dim tttt As String
lr = Cells(Rows.Count, 2).End(xlUp).Row
Set rngOut = Range("C15")
Set rng = Range("B2:B" & lr)
For Each c In rng
'MsgBox c
Set fLoc = Range("A:A").Find(c.Value, , xlValues)
If Not fLoc Is Nothing Then
fAdr = fLoc.Address
Do
If fLoc.Offset(0, 6) = "1" Then
c.Offset(0, 4) = c.Offset(0, 4).Value & fLoc.Offset(0, 7).Value & ", "
End If
fLoc.Value = c.Value
Set fLoc = Range("A:A").FindNext(fLoc)
Loop While fAdr <> fLoc.Address
tttt = Left(c.Offset(0, 4).Value, Len(c.Offset(0, 4).Value) - 1)
End If
'Columns("F").AutoFit
Next
MsgBox tttt
rngOut.Resize(UBound(Split(tttt.Text, ","))).Value = Application.Transpose(Split(tttt.Text, ","))
End Sub
Sub kjlkjlkj()
Dim t As String
t = InputBox("String")
ActiveSheet.Range("C15").Resize(UBound(Split(t, ",")) + 1).Value = _
Application.Transpose(Application.Trim(Split(t, ",")))
End Sub
I'm trying to concatenate rows.
The first cell is populated correctly; however, each cell after that is the same as the first cell.
The first cell is FS_Tier_1 , FS_CAP_1_001
The next cell should be FS_Tier_1 , FS_CAP_1_002
The cell after that should be FS_Tier_1 , FS_CAP_1_003, and so on.
Each cell shows FS_Tier_1 , FS_CAP_1_001.
Sub Concatenate_Cap1()
With Worksheets("PD Code Structure")
Dim i As Integer
Dim cell As Range
Dim Rng1 As Range
Set Rng1 = Range("F2:F1006")
i = 2
For Each cell In Rng1
If InStr(Cells(i, 3).Value, "FS_Tier_") And InStr(Cells(i, 8).Value, "FS_CAP_1_") Then
Range("F2:F1006").Formula = Cells(i, 3).Value & " , " & Cells(i, 8).Value
i = i + 1
End If
Next cell
End With
End Sub
You're setting the whole range to the same value here.
Range("F2:F1006").Formula = Cells(i, 3).Value & " , " & Cells(i, 8).Value
Something like this should work:
Sub Concatenate_Cap1()
Dim c As Range, rw As range, v3, v8
For Each c in Worksheets("PD Code Structure").Range("F2:F1006")
v3 = c.EntireRow.cells(3).value
v8 = c.EntireRow.cells(8).value
If InStr(v3, "FS_Tier_") And InStr(v8, "FS_CAP_1_") Then
c.value = v3 & " , " & v8
End If
Next cell
End Sub