Newbie question: I have module, originally made by Roger Govier.
It uses an input cell header and creates a dynamic named range for the non empty cells positioned under header. The created named range will be labeled as the value of the header cell.
Private Sub CreateNamedRange(header As range)
Dim wb As Workbook
Dim WS As Worksheet
Dim rStartCell As range
Dim rData As range
Dim rCol As range
Dim lCol As Long
Dim sSheet As String
Dim Rowno As Long
' get table location
Set rStartCell = header
Set WS = rStartCell.Worksheet
Set wb = WS.Parent
sSheet = "'" & WS.Name & "'"
With rStartCell
Rowno = .row
Set rData = .CurrentRegion
End With
Set rData = WS.range(rStartCell, WS.Cells(Rowno, rStartCell.Column))
Set rCol = rData.Columns
lCol = rCol.Column
wb.Names.Add Name:=Replace(rCol.Cells(1).Value, " ", "_"), _
RefersToR1C1:="=" & sSheet & "!" & rCol.Cells(2).Address(ReferenceStyle:=xlR1C1) & ":INDEX(C" & lCol & ",LOOKUP(2,1/(C" & lCol & "<>""""),ROW(C" & lCol & ")))"
End Sub
I want to modify this code so that instead of creating a named range it only returns the returns the range of the what would have been the named range.
Example:
We have a header in A1, and data in A2:A5.
Now: If we call CreateNamedRange(.range("A1")), it creates a dynamic named range for A2:A5.
Goal: If we call CreateNamedRange(.range("A1")) it returns .range("A2:A5") to a variable in the VBA code:
dim myRange As Range
set myRange = CreateNamedRange(.range("A1"))
First thing you should note is that Subs do not return any value and thus myRange = CreateNamedRange(.range("A1")) does not make any sense (with your Sub; it does make sense with the Function in this answer).
The function below returns a range, in the same column that the input range, starting from the next row and including all the ones below until finding a blank cell. This range is called "anyName" (and thus you can access it via Range("anyName")).
Private Function CreateNamedRange(header As Range) As Range
Dim curRow As Long: curRow = header.Row + 1
Set tempRange = header.Worksheet.Cells(curRow, header.Column)
Do While (Not IsEmpty(tempRange))
curRow = curRow + 1
Set tempRange = header.Worksheet.Cells(curRow, header.Column)
Loop
Set CreateNamedRange = header.Worksheet.Range(header.Worksheet.Cells(header.Row + 1, header.Column), header.Worksheet.Cells(curRow, header.Column))
CreateNamedRange.Name = "anyName"
End Function
If you already have the beginning cell activated you can just use
Set myRange = Range(ActiveCell.Address, ActiveCell.Offset.End(xlDown).Address)
to set your range for all entries below the active cell. If you don't have it activated, you can just use your rstartCell reference with an offset
Set myRange = Range(rStartCell.Offset(1), rStartCell.Offset(1).Offset.End(xlDown).Address)
Then you can just add the named range in the next line
Related
I have a worksheet (named RsOut) with 235 columns. I need to overwrite the values in only certain columns with data from another sheet(named rsTrans). Both sheets have a unique identifier that I am using to match.
I decided to use the Sumif function to populate the rsOut worksheet. Where I ran into a snag is I cannot figure out how to run the script for all rows in the column that have data.
Once we figure this out, I need to repeat this process for roughly 15 other columns.
My over-arching question is even after we get the sumif to work properly, what is the most efficient way to execute the code so that it repeats 15 more times?
The Criteria list and the CriteriaRange will always have the same location. But the Sum Range and the column where the results are inserted will change for each of the 15 columns.
So, Thoughts on the most efficient way to proceed...maybe separate the sumif code as it's own block and call upon it instead of repeating the steps over and over, and/or list out all the sum ranges and all the insert ranges, so the script just loops through them..Would love your insight VBA masters.
Issue:
I think my main issue is that I tried to use a rngList as the criteria.
I also tried to separate the sumif as a separate block of code, to call on. I may have screwed something up there as well.
The error highlights on the Set sumRange row. (Runtime error 1004 - Method 'Range' of Object '_Worksheet' Failed.
Any help you can provide would be greatly appreciated!!
Sub SumifmovewsTransdatatowsOut()
Dim wb As Workbook, wsOut As Worksheet
Dim wsTrans As Worksheet, rngList As Range
Dim sumRange As Range
Dim criteriaRange As Range
Dim criteria As Long 'Setting as long because the IDs (criteria) are at least 20 characters. Should this be a range??
Set wb = ThisWorkbook
Set wsTrans = Worksheets("DEL SOURCE_Translator") 'Worksheet that contains analysis and results that need to be inserted into wsOut
Set wsOut = Worksheets("FID GDMR - Output_2") 'Worksheet where you are pasting results from wsTrans
Set rngList = wsOut.Range("B2:B" & wsOut.Cells(Rows.Count, "B").End(xlUp).Row) 'this range of IDs will be different every run, thus adding in the count to find last row...or do I not need the rnglist at all? Just run the sumif for all criteria B2:b
Set sumRange = wsTrans.Range("ag21:ag") 'Values in wsTrans that need to be added to wsOut
Set criteriaRange = wsTrans.Range("AA21:AA") 'Range of IDs found on wsTrans
criteria = rngList
Sumif
End Sub
'Standard Sumif formula
Sub Sumif()
wsOut.Range("AT2:AT") = WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria)
End Sub
'OR should the Sumif formula be: rng.Formula = "=SUMIF(criteriaRange,rngList,sumRange)"
SUBSEQUENT TESTING after receiving recommendations:
I tested using the second recommendation only because a future user could easily change out the array values if the columns shifted on the wsout template. Below is the code that I used and the resulting error.
Result issues:
the result in each changed cell is #NAME?
a pop up box shows up for each request. It is looking for the translater. See screenshot below. If I x out of each pop up box, the script completes and each cell has the #NAME?
enter image description here
Thoughts on what went wrong?
Code:
Sub test2()
Dim wsTrans As Worksheet: Dim wsOut As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim i As Integer: Dim arr
arr = Array("AG:AT", "AJ:BB", "AM:BJ", "AT:BR", "AZ:CA", "BP:DE", "BW:DO") 'change as needed
Set wsTrans = Sheets("DEL SOURCE_Translator") 'change as needed
Set wsOut = Sheets("FID GDMR - Output_2") 'change as needed
rgCrit = wsTrans.Name & "!" & wsTrans.Columns(27).Address 'Column 27 is AA in wsTrans which contains the criteria range
Set rgR = wsOut.Range("B2", wsOut.Range("B2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
For i = LBound(arr) To UBound(arr)
rgSum = wsTrans.Name & "!" & Split(arr(i), ":")(0) & ":" & Split(arr(i), ":")(0)
With rgR.Offset(0, Range(Split(arr(i), ":")(1) & 1).Column - rgR.Column)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
Next
End Sub
'Sum Ranges in wsTrans: AG, AJ, AM, AT, AZ, BP, BW
'Result Columns in wsOut: AT, BB, BJ, BR, CA, DE, DO
Additional Review:
Also, to test, instead of x'ing out of the pop up, I selected my file in the pop up. when I did, a second pop up below showed up. Interestingly, the sheet name is missing the DEL on the front. When I select the correct sheet, I still get the #Name? error.
enter image description here
Okay, so your question is a little too broad for this website. The general rule is each question should address one specific issue.
That being said, I think I can help you with a few easy to solve points.
1) Making Sumif Work:
Using Sumif() function inside a Sub is the same as using it in an Excel formula. First you need two full ranges, next you need a value to lookup.
Full ranges: wsTrans.Range("ag21:ag") is not going to work because it doesn't have an end row. Instead, it needs to be wsTrans.Range("AG21:AG100"). Now since you don't seem to know your last row, I would suggest you find that first and then integrate it into all your ranges. I'm using the variable lRow below.
Option Explicit
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim lRow As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
Debug.Print Application.WorksheetFunction.SumIf(criteriaRange, aCriteria(1, 1), sumRange)
End Sub
The above sub returns:
Which is correct considering the following sheets:
2) Making it loop through the criteria list
You've already made a great start on looping through this criteria list by importing rngList into an array. Next we just need to loop that array like so:
Option Explicit
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim lRow As Long
Dim I As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
For I = 1 To UBound(aCriteria, 1)
Debug.Print "Sum of " & aCriteria(I, 1) & "=" & _
Application.WorksheetFunction. _
SumIf(criteriaRange, aCriteria(I, 1), sumRange)
Next I
End Sub
This results in an output of:
Then to finish it off, you'll need to check which column to put it in, maybe with a .Find or maybe with a Match() of the column headers, but I don't know what your data looks like. But, if you just want to output that range to your output sheet here's how to do that:
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim OutputSums
Dim lRow As Long
Dim I As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
ReDim OutputSums(1 To UBound(aCriteria, 1), 1 To 1)
For I = 1 To UBound(aCriteria, 1)
OutputSums(I, 1) = Application.WorksheetFunction. _
SumIf(criteriaRange, aCriteria(I, 1), sumRange)
Next I
wsOut.Range("C2").Resize(UBound(OutputSums, 1), 1) = OutputSums
End Sub
Resulting in:
If I understand you correctly, besides Mr. Cameron's answers, another way maybe you can have the VBA using formula.
Before running the sub is something like this :
After running the sub (expected result) is something like this:
Please ignore the fill color, the sorting and the value, as they are used is just to be easier to calculate manually for the expected result.
The Criteria list and the CriteriaRange will always have the same
location. But the Sum Range and the column where the results are
inserted will change for each of the 15 columns.
Since you don't mention where are the columns for the Sum Range will be, this code assume that it will be in a consecutive column to the right of column ID, as seen in the image of sheet1 ---> rgSUM1, rgSUM2, rgSUM3.
And because you also don't mention in what column in sheet2 the result is, this code assume that it will be in a consecutive column to the right of column ID, as seen in the image of sheet2 ---> SUM1, SUM2, SUM3.
If your Sum Range columns are random and/or your Sum Result columns are random, then you can't use this code. For example : your rgSum1 is in column D sheet1 - rgSum1Result sheet2 column Z, rgSum2 is in column AZ sheet1 - rgSum2Result sheet2 column F, rgSum3 is in column Q sheet1 - rgSum3Result sheet2 column DK, and so on until 15 columns. I think it will need an array of column letter for both rgSum and rgSumResult if they are random.
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim col As Integer
col = 3 'change as needed
Set sh1 = Sheets("Sheet1") 'change as needed
Set sh2 = Sheets("Sheet2") 'change as needed
rgCrit = sh1.Name & "!" & sh1.Columns(1).Address 'change as needed
rgSum = sh1.Name & "!" & Replace(sh1.Columns(2).Address, "$", "") 'change as needed
Set rgR = sh2.Range("A2", sh2.Range("A2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
With rgR.Resize(rgR.Rows.Count, col).Offset(0, 1)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
End Sub
Basically the code just fill the range of the expected result with SUMIF formula.
col = how many columns are there as the sum range
sh1 (wsTrans in your case) is the sheet where the ID and the multiple sum range are.
sh2 (wsOut in your case) is the sheet where the ID to sum and the multiple sum result are.
rgCrit is the sh1 name with the column of the range of criteria (column A, (ID) in this case)
rgSum is the sh1 name with the first column of Sum Range (column B in this case)
rgR is the range of the unique ID in sheet2 (column A in this case, must have no blank cell in between, because it use xldown) and finally, startCell is the first cell address of rgR
Below if the SumRange and ResultRange are random column.
Sub test2()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim i As Integer: Dim arr
arr = Array("B:G", "F:E", "D:B") 'change as needed
Set sh1 = Sheets("Sheet13") 'change as needed
Set sh2 = Sheets("Sheet14") 'change as needed
rgCrit = sh1.Name & "!" & sh1.Columns(1).Address 'change as needed
Set rgR = sh2.Range("A2", sh2.Range("A2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
For i = LBound(arr) To UBound(arr)
rgSum = sh1.Name & "!" & Split(arr(i), ":")(0) & ":" & Split(arr(i), ":")(0)
With rgR.Offset(0, Range(Split(arr(i), ":")(1) & 1).Column - rgR.Column)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
Next
End Sub
The arr value is in pair : sum range column - sum result column.
Example arr in code :
First loop : sum range column is B (sheet1) where the result will be in column G (sheet2).
Second loop: sum range column is F (sheet1) where the result will be in column E (sheet2).
Third loop: sum range column is D (sheet1) where the result will be in column B (sheet2).
First question ever here, I am the newbiest newbie..
So.. what I am trying to get is:
to find if in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2. if there are, then copy the value from sheet2 column A row x to sheet2 column P row y.
rows x and y are where the identical values are on each sheet.
this is my code:
Sub ccopiazanrfact()
Dim camion As Worksheet
Dim facturi As Worksheet
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Dim nrcomanda As String
Dim nrfactura As String
For a = 2 To facturi.Range("F" & Rows.Count).End(xlUp).Row
nrcomanda = facturi.Range("F" & a).Value
For b = 4 To camion.Range("E" & Rows.Count).End(xlUp).Row
If camion.Range("E" & b).Value = facturi.Range("F" & a).Value Then
camion.Range("P" & b) = facturi.Range("A" & a).Value
Exit For
End If
Next b
Next a
End Sub
I would recommend using arrays to achieve what you want. Nested looping over ranges can make it very slow. Is this what you are trying? (UNTESTED). As I have not tested it, I would recommend making a backup of your data before you test this code.
I have commented the code. But if you still have a question or find an error/bug in the below code then simply ask.
Option Explicit
Sub ccopiazanrfact()
Dim Camion As Worksheet
Dim Facturi As Worksheet
Set Camion = ThisWorkbook.Sheets("B816RUS")
Set Facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
'~~> Declare 2 arrays
Dim ArCamion As Variant
Dim ArFacturi As Variant
Dim LRow As Long
'~~> Find last row in Col E of Sheets("B816RUS")
LRow = Camion.Range("E" & Camion.Rows.Count).End(xlUp).Row
'~~> Store Values from E4:P last row in the array. We have taken E:P
'~~> because we are replacing the value in P if match found
ArCamion = Camion.Range("E4:P" & LRow).Value
'~~> Find last row in Col E of Sheets("EVIDENTA FACTURI")
LRow = ArFacturi.Range("F" & ArFacturi.Rows.Count).End(xlUp).Row
'~~> Store Values from A2:F last row in the array. We have taken A:F
'~~> because we are replacing the value in P with A
ArFacturi = Facturi.Range("A2:F" & LRow).Value
Dim i As Long, j As Long
For i = 2 To UBound(ArFacturi)
For j = 4 To UBound(ArCamion)
'~~> Checking if camion.Range("E" & j) = facturi.Range("F" & i)
If ArCamion(j, 1) = ArFacturi(i, 6) Then
'~~> Replacing camion.Range("P" & j) with facturi.Range("A" & i)
ArCamion(j, 12) = ArFacturi(i, 1)
Exit For
End If
Next j
Next i
'~~> Write the array back to the worksheet in one go
Camion.Range("E4:P" & LRow).Resize(UBound(ArCamion), 12).Value = ArCamion
End Sub
in the end, I came up with this and works instantly, get’s all the data filled within a blink of an eye. When I tried it first time I thought i forgot to clear the data before running the code:
Sub FindMatchingValues()
'Declare variables for the worksheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'Set the variables to refer to the worksheets
Set ws1 = Worksheets("B816RUS")
Set ws2 = Worksheets("EVIDENTA FACTURI")
'Declare variables for the ranges to compare
Dim rng1 As Range
Dim rng2 As Range
'Set the ranges to the columns to compare
Set rng1 = ws1.Range("E1", ws1.Range("E" & Rows.Count).End(xlUp))
Set rng2 = ws2.Range("F1", ws2.Range("F" & Rows.Count).End(xlUp))
'Loop through each cell in the first range
For Each cell1 In rng1
'Use the Match function to find the matching value in the second range
Dim match As Variant
match = Application.match(cell1.Value, rng2, 0)
'If a match was found, copy the value from column A in the second worksheet to column P in the first worksheet
If Not IsError(match) Then
ws1.Range("P" & cell1.Row).Value = ws2.Range("A" & match).Value
End If
Next cell1
End Sub
Please, test the next code. It should be very fast, using arrays and Find function:
Sub ccopiazaNrfact()
Dim camion As Worksheet, facturi As Worksheet, cellMatch As Range, rngE As Range
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Set rngE = camion.Range("E4:E" & camion.Range("E" & camion.rows.count).End(xlUp).row)
Dim a As Long, arrFact, arrP, nrComanda As String
arrP = camion.Range("P1:P" & camion.Range("E" & rows.count).End(xlUp).row).Value
arrFact = facturi.Range("A2:F" & facturi.Range("F" & rows.count).End(xlUp).row).Value
Debug.Print UBound(arrP): Stop
For a = 1 To UBound(arrFact)
nrComanda = arrFact(a, 6)
Set cellMatch = rngE.Find(What:=nrComanda, After:=rngE.cells(1, 1), LookIn:=xlValues, lookAt:=xlWhole)
If Not cellMatch Is Nothing Then
arrP(cellMatch.row, 1) = arrFact(a, 1)
End If
Next a
camion.Range("P1").Resize(UBound(arrP), 1).Value = arrP
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it...
A VBA Lookup: Using Arrays and a Dictionary
Option Explicit
Sub CopiazaNrFact()
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the Source Compare and Value ranges to arrays.
' f - Facturi (Source), c - Compare, v - Value
Dim frg As Range, fcData() As Variant, fvData() As Variant, frCont As Long
With wb.Sheets("EVIDENTA FACTURI")
' Compare
Set frg = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
frCont = frg.Rows.Count
fcData = frg.Value ' write to array
' Value
Set frg = frg.EntireRow.Columns("A")
fvData = frg.Value ' write to array
End With
' Write the unique values from the Source Compare array to the 'keys',
' and their associated values from the Source Values array to the 'items'
' of a dictionary.
Dim fDict As Object: Set fDict = CreateObject("Scripting.Dictionary")
fDict.CompareMode = vbTextCompare
Dim fr As Long, NrFacturi As String
For fr = 1 To frCont
NrFacturi = CStr(fcData(fr, 1))
If Len(NrFacturi) > 0 Then ' exclude blanks
fDict(NrFacturi) = fvData(fr, 1)
End If
Next fr
' Write the values from the Destination Compare range to an array
' and define the resulting same-sized Destination Value array.
' c - Camion (Destination), c - Compare, v - Value
Dim crg As Range, ccData() As Variant, cvData() As Variant, crCont As Long
With wb.Sheets("B816RUS")
' Compare
Set crg = .Range("E4", .Cells(.Rows.Count, "E").End(xlUp))
crCont = crg.Rows.Count
ccData = crg.Value ' write to array
' Value
Set crg = crg.EntireRow.Columns("P")
ReDim cvData(1 To crCont, 1 To 1) ' define
End With
' For each value in the Destination Compare array, attempt to find
' a match in the 'keys' of the dictionary, and write the associated 'item'
' to the same row of the Destination Value array.
Dim cr As Long, NrCamion As String
For cr = 1 To crCont
NrCamion = CStr(ccData(cr, 1))
If fDict.Exists(NrCamion) Then cvData(cr, 1) = fDict(NrCamion)
Next cr
' Write the values from the Destination Value array
' to the Destination Value range.
crg.Value = cvData
End Sub
I am new to VBA Macro. i just want to know how to get the last row that has value within a range
Set MyRange = Worksheets(strSheet).Range(strColumn & "1")
GetLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
this code could find the last row for the whole sheet.. i just want it to find the last non null value cells
(
like in this case in the picture.. for the ("A8") range, the last row result should be ("A9:B9")
"A9:B9" cannot be last row... It is a range.
If you need such a range, but based on the last empty row, starting from a specific cell, you can use the next approach:
Sub testLastRowRange()
Dim sh As Worksheet, myRange As Range, lastRow As Long, strColumn As String
Dim lastCol As Long, endingRowRng As Range, strSheet As String
strSheet = ActiveSheet.Name 'please, use here your real sheet name
Set sh = Worksheets(strSheet)
strColumn = "A"
Set myRange = sh.Range(strColumn & 8)
lastRow = myRange.End(xlDown).row
lastCol = myRange.End(xlToRight).Column
Set endingRowRng = sh.Range(sh.Cells(lastRow, myRange.Column), sh.Cells(lastRow, lastCol))
Debug.Print endingRowRng.address
End Sub
For your specific example you could use CurrentRegion property.
This is based on the ActiveCell which is not generally advisable.
Sub x()
Dim r As Range
Set r = ActiveCell.CurrentRegion
MsgBox r.Address
End Sub
Below, I have code that sends a personalized SMS message and includes the name. I got that part to work. Now, I just need to make it so that my range is dynamic and moves down the respective column until there is no one left to message. In it's current state, it will only message the first person. I tried looking up dynamic range tutorials, loops, etc. but they were either too complex for me to grasp or would require me to rewrite what I already have working.
Private Sub btnSend_Click()
Dim contactNumberRange As Range
Dim messageRange As Range
Dim clientNameRange As Range
Dim phoneCell As Range
Dim messageCell As Range
Dim nameCell As Range
Set contactNumberRange = Range("D2") //Need to make this range dynamic
Set messageRange = Range("E2") //This too
Set clientNameRange = Range("A2") //This aswell
For Each phoneCell In contactNumberRange
For Each messageCell In messageRange
For Each nameCell In clientNameRange
SendMessage FROMPHONE, nameCell.Value, phoneCell.Value, messageCell.Value
Next
Next
Next
Me.Hide
End Sub
You just need to ammend your ranges with a last row variable.
Also, qualify those ranges with a worksheet!
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set contactNumberRange = ws.Range("D2:D" & LR)
Set messageRange = ws.Range("E2:E" & LR)
Set clientNameRange = ws.Range("A2:A" & LR)
For Each phoneCell In contactNumberRange
For Each messageCell In messageRange
For Each nameCell In clientNameRange
SendMessage FROMPHONE, nameCell.Value, phoneCell.Value, messageCell.Value
Next nameCell
Next messageCell
Next phoneCell
Code works as expected until the last line where I attempt to move values from one range to another at which point I'm getting a "run time error 1004", so must be doing something wrong.
the range "NewRng" does produce the correct string "$A$1883:$R$2105" which if entered manually into the last line (replacing the "NewRng" reference) it produces the correct results.
Thanks in advance
Dim NevwebLR As String
With Sheets("NevWeb file")
NevwebLR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim DropShipLR As String
With Sheets("Drop Shipments")
DropShipLR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim NevwebLR1 As String
NevwebLR1 = NevwebLR + 1
Dim dropshipglue As Long
dropshipglue = Val(NevwebLR) + Val(DropShipLR)
Dim rng1 As Range, rng2 As Range
Dim NewRng As Range
With ThisWorkbook.Sheets("Results")
Set rng1 = .Range("A" & NevwebLR1)
Set rng2 = .Range("R" & dropshipglue)
Set NewRng = .Range(rng1, rng2)
Debug.Print NewRng.Address
End With
Sheets("results").Range(NewRng).Value = Sheets("Drop Shipments").Range("A1:R" & DropShipLR).Value
You have your destination range already as Range-object, so change the last line to
NewRng.Value = Sheets("Drop Shipments").Range("A1:R" & DropShipLR).Value