I have a command button named "update" to activate the macro.
The macro should check if in the range G:25 to G:33 the cell is empty.
If empty nothing should happen.
If you write a number into the Box it should copy that number and then put it into a cell on the second worksheet.
So Sheet1.(G:25) should be copied into sheet2.(G14) and then iterate till G:25
Nothing is happening.
Sheet1 = "Übersicht"
Sheet2 = "Semester01"
Dim cell As Range, c As Integer, score As Integer
Dim rng As Range
Set rng = Range("G25:G33")
c = 14
For Each cell In rng
score = Cells.Value
If score < 0 Then
zelle.Copy
Sheet2.Cells(7, c).Select
Worksheet("Semester01").Paste
c = c + 1
End If
Next cell
End Sub
I don't see the point for all the extra variables and missing/confusing parent references. I don't see where zelle comes from.
Option Explicit
sub go()
Dim cell As Range, c As Integer
c = 14
For Each cell In sheet1.Range("G25:G33")
If val(cell.Value) < 0 Then
cell.Copy destination:=Sheet2.Cells(7, c)
c = c + 1
End If
Next cell
End Sub
If you use Option Explicit you can avoid misspelling variable.
Copy Cells If Criteria...
Option Explicit
Sub ZelleCopy()
Const cShS As String = "Übersicht" ' Source Worksheet Name
Const cShT As String = "Semester01" ' Target Worksheet Name
Const cRng As String = "G25:G33" ' Source Column Range Address
Const cTgtFR As Long = 14 ' Target First Row Number
Const cTgtCol As Variant = "G" ' Target Column Letter/Number ' or 7
Dim wsS As Worksheet ' Source Worksheet
Dim wsT As Worksheet ' Target Worksheet
Dim cell As Range ' Current Cell (For Each Control Variable)
Dim c As Long ' Target Cell (Row) Counter
Dim Score As Long ' Criteria Value
' Create references to Source and Target Worksheets.
With ThisWorkbook
Set wsS = .Worksheets(cShS)
Set wsT = .Worksheets(cShT)
End With
' Write Target First Row Number to Target Row Counter.
c = cTgtFR
' Loop through each cell (row) in Source Column Range.
For Each cell In wsS.Range(cRng)
' Write value of Current Cell to Criteria Value.
Score = cell.Value
' Check if Criteria Value is less than 0.
If Score < 0 Then
' Write Criteria Value to current cell in Target Column.
wsT.Cells(c, cTgtCol) = Score
' Count Target Row.
c = c + 1
End If
Next
End Sub
Related
I have written a code in which I am trying to use two different formulas with a set of conditions like if we take RUZ currency into consideration. where we have tenors between (SW- 1Y), the formula should be =1/(1/R208C[-5]+RC12/10000) and for the rest of the tenors (2Y, 3Y,5Y) the formula should be =1*RC[-5]. this condition is only applicable on RUZ ccy, for the rest, one formula per ccy(currency) will be used for all their respective tenors.
the formula is placed in column P,
tenors are placed in column B
Sub Get_vpl()
' Define Constants.
Const wsName As String = "DS"
Const FirstRow As Long = 5
Const srcCol As String = "A"
Const tgtCol As String = "P"
Dim Criteria As Variant
Dim Formulas As Variant
Criteria = Array("RUB", "TRY", "TWD", "UAH", "UYU", "VND") ' add more...
Formulas = Array( "=1/(1/R208C[-5]+RC12/10000)", "=1*RC[-5]", "=1/(1/R232C[-5]+RC12/1)", "=1*RC[-5]", "=1*RC[-5]", "=1*RC[-5]") ' add more...
' Define the Source Column Range.
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheet.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
' Calculate Last Non-Empty Row.
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, srcCol).End(xlUp).Row
' Define Source Column Range.
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, srcCol), ws.Cells(LastRow, srcCol))
' Prepare to write to Target Column Range.
' Calculate Column Offset.
Dim ColOffset As Long
ColOffset = ws.Columns(tgtCol).Column - ws.Columns(srcCol).Column
' Declare variables.
Dim CurPos As Variant ' Current Position
Dim cel As Range ' Current Cell Range
' Write formulas to Target Column Range.
Application.ScreenUpdating = False
' Iterate the cell ranges in Source Range.
For Each cel In rng.Cells
' Check if Current Cell Range in Source Column Range is not empty.
If Not IsEmpty(cel) Then
' Try to find the value in Current Cell Range in Criteria Array
' and write the position to Current Position
CurPos = Application.Match(cel, Criteria, 0)
' Check if value in Current Cell Range has been found
' in Criteria Array.
If Not IsError(CurPos) Then
' Write formula from Formulas Array to current Target Cell
' Range, using Current Position in Criteria Array.
cel.Offset(, ColOffset).Formula = _
Application.Index(Formulas, CurPos)
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
I have done more than intended to your code because I had so much difficulty understanding what you need. However, I'm rather pleased with the result and hope you will be, too. Note that I never ran the code and it may, therefore, contain minor bugs or typos which I shall be happy to rectify if you point them out.
Option Explicit
Enum Nws ' worksheet navigation
NwsFirstRow = 5
NwsCcy = 1 ' Columns: A = Currency
NwsTenor ' B = Tenor
NwsTarget = 16 ' P = Target
End Enum
Sub Get_vpl()
' 116
' Define Constants.
Const wsName As String = "DS"
' Declare variables.
Dim Wb As Workbook
Dim Ws As Worksheet
Dim CcyIdx As Integer ' return value from CurrencyIndex()
Dim R As Long ' loop counter: rows
Set Wb = ThisWorkbook
Set Ws = Wb.Worksheets(wsName)
Application.ScreenUpdating = False
With Ws
' this syntax is easier because you need the row number R
For R = NwsFirstRow To .Cells(.Rows.Count, NwsCcy).End(xlUp).Row
CcyIdx = CurrencyIndex(.Cells(R, NwsCcy).Value)
If CcyIdx >= 0 Then
.Cells(R, NwsTarget).Formula = ChooseFormula(CcyIdx, .Cells(R, NwsTenor).Value)
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function ChooseFormula(ByVal CcyIdx As Integer, _
ByVal Tenor As String) As String
' 116
' return the formula specified by Idx or Formula(0)
Dim Idx As Integer
Dim Formula(2) As String
' the advantage of the syntax you chose is that the array
' is dimensioned automatically.
' Here the advantage is clarity.
Formula(0) = "=1*RC[-5]"
Formula(1) = "=1/(1/R208C[-5]+RC12/10000)"
Formula(2) = "=1/(1/R232C[-5]+RC12/1)"
If CcyIdx = 0 Then
If InStr("1Y,2Y,3Y,5Y", Tenor) Then Idx = 1
End If
ChooseFormula = Formula(Idx)
End Function
Private Function CurrencyIndex(ByVal Currcy As String) As Integer
' 116
' return -1 if not found or blank
Dim Ccy() As String ' list of currencies
Dim i As Integer
' I added "RUZ" in position 0 (change to suit and match in ChooseFormula())
' this syntax uses less space but doesn't support MATCH()
Ccy = Split("RUZ RUB TRY TWD UAH UYU VND") ' add more...
If Len(Trim(Currcy)) Then
For i = UBound(Ccy) To 0 Step -1
If StrComp(Currcy, Ccy(i), vbTextCompare) = 0 Then Exit For
Next i
Else
i = -1
End If
CurrencyIndex = i
End Function
I found your Criteria rather useless in this context. Perhaps that's why I gave it a task. The function CurrencyIndex() returns the index number of the current currency and uses this number thereafter in place of the actual currency code. For this purpose I added "RUZ" to your array. I have it in first position but any other number will do as well.
Please look at the function ChooseFormula(). It seems you have only 3 formulas. I assigned the index 0 to the most common one and made that the default. For the rest of it, the CcyIdx is passed to the function as an argument and if that index = 0 it identifies "RUZ" and gives it special treatment. I'm not sure that the treatment I assigned is 100% correct or workable but I think the code is simple and you should be able to modify it as required. Observe that the function won't ever return Formula(2) in its present state but you can modify it easily to accommodate all kinds of conditions and many more possible formulas. Let me know if you need any help with that.
I have data organized into rows and in column B I have data titles. I want to select the data after the titles and then give them range names based on that title. I was able to code a solution that could name column ranges dynamically this way, but when altering it to name the rows of data I run into a 1004 error, specifically at the rng.CreateNames point.
Sub RowNames()
Dim ws As Worksheet, firstCol As Long, lastCol As Long, rowNum As Long, r As Integer, n As Integer, rng As Range, rngName As Range
Set ws = ThisWorkbook.Sheets("MonthlySales")
Set rng = ws.Range("B2:N41")
For n = 1 To rng.Rows.Count
For r = rng.Columns.Count To 1 Step -1
rowNum = rng.Rows(n).Row
firstCol = rng.Columns(1).Column
lastCol = rng.Columns(r).Column
If Cells(firstCol, rowNum).Value <> "" Then
Set rngName = Range(Cells(firstCol, rowNum), Cells(lastCol, rowNum))
rngName.CreateNames Left:=True
Exit For
End If
Next r
Next n
End Sub
Naming Row Ranges
Range.CreateNames Method
Frankly, never heard of it. Basically, in this case, you take a range and write different names in its first column and when you loop through the rows, for each row you write something like Range("A1:D1").CreateNames Left:=True to create a named range whose name is the value in A1 and it will refer to the range B1:D1.
To mix it up, this example (I think OP also) assumes that there might be blank cells in the first column, and the number of cells in each row range may vary. Each row range will be checked backwards for a value which will define its size.
The Code
Option Explicit
Sub RowNames()
' Define worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("MonthlySales")
' Define Source Range.
Dim rng As Range
Set rng = ws.Range("B2:N41")
' Define Columns Count.
Dim ColumnsCount As Long
ColumnsCount = rng.Columns.Count
Dim RowRange As Range ' Current Row Range
Dim r As Long ' Source Range Rows Counter
Dim c As Long ' Source Range / Current Row Range Columns Counter
' Loop through rows of Source Range.
For r = 1 To rng.Rows.Count
' Create a reference to the current Row Range.
Set RowRange = rng.Rows(r)
' Check if first cell of current Row Range contains a value,
' making it a possible candidate for a defined name.
If RowRange.Cells(1).Value <> "" Then
' Loop through cells (columns) of current Row Range backwards.
For c = ColumnsCount To 2 Step -1
' Check if current cell in current Row Range contains a value.
If RowRange.Cells(c) <> "" Then
' Create a named range from value in first cell. The range
' is defined from the second cell to to current cell
' in current Row Range.
RowRange.Cells(1).Resize(, c).CreateNames Left:=True
' Exit loop, we got what we came for (the named range).
Exit For
End If
Next c
End If
Next r
End Sub
Dear stack overflow community:
To be brief, the goal of this program is to allow user to input text in Cell C53 and for the program to find matching text in a string in contained in each row within Column A, then return the text in column B on the same row if found (otherwise, return "Use your best judgement".)
I've successfully created the VBA code to find a matching text in a specific row in Column A and return the value in the same row in column B. However, it only works on one row hardcoded into the code. I need to adjust it to loop through a range of rows in column A because there may be matching text in other rows.
My code currently looks like this:
Sub Test_2()
Dim SearchString, SearchText
SearchKey = Range("A1")
SearchNote = Range("C53")
If InStr(SearchNote, SearchKey) > 0 Then
Range("C59").Value = Range("B1").Value
Else
Range("C59").Value = "Please use your best judgement."
End If
End Sub
Hence, if A1 contains "limit", and I type into C53 "client wants to upgrade limit", it will return to C59 the text in B1 because it was found.
The only addition I have been trying to make is nesting what I currently have into a loop to check other rows in Column A. For example, if A1 was "cheque" and A2 was "limit", my current code would only check A1 and not find a match resulting in the prompt "Please use your best judgement." It should be able to check A1, A2, A3 ... A50 ...
I've been having difficulties translating this to code in VBA, and was hoping for some assistance.
Find Word in Sentence
The 1st code goes into a standard module e.g. Module1. Only run the 1st procedure which is calling the 2nd procedure when needed.
Adjust the constants as you see fit. If this is used in one worksheet only then you have to change srcName and tgtName to the same string.
To automate this, copy the second short code to the sheet module (e.g. Sheet1) worksheet where the Answer and Question Cells are. Then you run nothing, it's automatic.
Standard Module e.g. Module1
Option Explicit
Public Const queCell As String = "C53" ' Question Cell
Sub writeAnswer()
' Data
Const srcName As String = "Sheet1" ' Source Worksheet Name
Const srcFirstRow As Long = 1 ' Source First Row Number
Const srcLastRowCol As String = "A" ' Source Last Row Column ID
Dim Cols As Variant: Cols = Array("A", "B") ' Source Column IDs
' Target
Const tgtName As String = "Sheet1" ' Target Worksheet Name
Const ansCell As String = "C59" ' Answer Cell
' Other
Const msg As String = "Please use your best judgement." ' Not Found Message
Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
' Define column range.
Dim src As Worksheet: Set src = wb.Worksheets(srcName)
Dim rng As Range
Set rng = src.Columns(srcLastRowCol).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < srcFirstRow Then Exit Sub
Set rng = src.Range(src.Cells(srcFirstRow, srcLastRowCol), rng)
' Write values from column range to jagged array (Data(0) & Data(1)).
Dim ubc As Long: ubc = UBound(Cols)
Dim Data As Variant: ReDim Data(ubc)
Dim j As Long
For j = 0 To ubc
getRange(Data(j), rng.Offset(, src.Columns(Cols(j)).Column _
- src.Columns(srcLastRowCol).Column))
If IsEmpty(Data) Then Exit Sub
Next
' Search Data(0) Array for string contained in Question Cell
' and write result from Data(1) Array to Answer Cell.
Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
Dim Sentence As String: Sentence = tgt.Range(queCell).Value
Dim i As Long
For i = 1 To UBound(Data(0))
If Sentence = "" Then Exit For
If Trim(Data(0)(i, 1)) <> "" Then
If InStr(1, Sentence, Trim(Data(0)(i, 1)), vbTextCompare) > 0 Then
tgt.Range(ansCell).Value = Data(1)(i, 1)
Exit Sub
End If
End If
Next i
' If string not found, write Not Found Message to Answer Cell.
tgt.Range(ansCell).Value = msg
End Sub
' Writes the values of a range to a 2D one-based array.
Sub getRange(ByRef Data As Variant, DataRange As Range)
Data = Empty
If DataRange Is Nothing Then Exit Sub
If DataRange.Rows.Count > 1 Or DataRange.Columns.Count > 1 Then
Data = DataRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = DataRange.Value
End If
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Range(queCell), Target) Is Nothing Then
writeAnswer
End If
End Sub
My data sheet ("srData") is a pivot table that is filled using a userform. All data have a unique ID in column A of the data sheet. In the userform checkboxes are selected, which will change the cells, in columns K:AB, interior color to white(2), else interior color is grey(15)
In my main worksheet ("Formulier"), based on the value of a drop down box (C6)where the unique ID is selected (i.e. SR-1, SR-2,SR-3 etc...), the headers from sheet("srData") are returned in column A of sheet("Formulier") starting from row 20 if the interior.colorindex=2. The values in the cells are returned in column D starting from row 20.
Now in Column Y and Z of ("srData") I have placed a hyperlink which links to a PDF.(see SR-4 first image) In column Y and Z there will allways be hyperlinks in the cells with interior.colorindex=2.
When I now select the unique ID from the dropdown on sheet("Formulier") I would like it to return an active hyperlink and not just tekst as it does now. Is this possible?
This is the code I have for returning the header and the values. The code was created by VBasic2008 so credit goes to him.
`
Option Explicit
Public Const CriteriaCell As String = "C6" ' Criteria Cell Range Address
Sub ColorSearch()
' Source
Const cSource As Variant = "srData" ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A" ' Criteria Column Letter/Number
Const cColumns As String = "K:AB" ' Columns Range Address
Const cHeaderRow As Long = 1 ' Header Row Number
Const cColorIndex As Long = 2 ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier" ' Worksheet Name/Index
Const cFr As Long = 20 ' First Row Number
Const cCol As Variant = "A" ' Column Letter/Number
Const cColVal As Variant = "D" ' Value Column Letter/Number
Dim Rng As Range ' Source Found Cell Range
Dim vntH As Variant ' Header Array
Dim vntC As Variant ' Color Array
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim vntTV As Variant ' Target Value Array
Dim i As Long ' Source/Color Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim sRow As Long ' Color Row
Dim SVal As String ' Search Value
Dim Noe As Long ' Source Number of Elements
' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Search for Search Value in Source Criteria Column and create
' a reference to Source Found Cell Range.
Set Rng = .Columns(cCriteriaColumn) _
.Find(SVal, , xlValues, xlWhole, , xlNext)
' Check if Search Value not found. Exit if.
If Rng Is Nothing Then Exit Sub
' Write row of Source Found Cell Range to Color Row.
sRow = Rng.Row
' Release rng variable (not needed anymore).
Set Rng = Nothing
' In Source Columns
With .Columns(cColumns)
' Copy Header Range to Header Array.
vntH = .Rows(cHeaderRow)
' Copy Color Range to Color Array.
vntC = .Rows(sRow)
' *** Copy Color Range to Value Array.
' Note: The values are also written to Color Array, but are
' later overwritten with the Color Indexes.
vntV = .Rows(sRow)
' Write number of columns in Source Columns to Source Number
' of Elements.
Noe = .Columns.Count
' Loop through columns of Color Range/Array.
For i = 1 To Noe
' Write current ColorIndex of Color Range to current
' element in Color Array.
vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
Next
End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)
' Loop through columns of Color Array.
For i = 1 To Noe
' Check if current value in Color Array is equal to Criteria
' Column Index.
If vntC(1, i) = cColorIndex Then
' Count row in Target Array.
k = k + 1
' Write value of current COLUMN in Header Array to
' element in current ROW of Target Array.
vntT(k, 1) = vntH(1, i)
' *** Write value of current COLUMN in Value Array to
' element in current ROW of Target Value Array.
vntTV(k, 1) = vntV(1, i)
End If
Next
' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Calculate Target Range by resizing the cell at the intersection of
' Target First Row and Target Column, by Number of Elements.
' Copy Target Array to Target Range.
.Cells(cFr, cCol).Resize(Noe) = vntT
' *** Calculate Target Value Range by resizing the cell at the
' intersection of Target First Row and Value Column, by Number of
' Elements.
' Copy Target Value Array to Target Value Range.
.Cells(cFr, cColVal).Resize(Noe) = vntTV
End With
End Sub
`
Make a backup before and give this a try:
Option Explicit
Public Const CriteriaCell As String = "C6" ' Criteria Cell Range Address
Sub ColorSearch()
' Source
Const cSource As Variant = "srData" ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A" ' Criteria Column Letter/Number
Const cColumns As String = "K:AB" ' Columns Range Address
Const cHeaderRow As Long = 1 ' Header Row Number
Const cColorIndex As Long = 2 ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier" ' Worksheet Name/Index
Const cFr As Long = 20 ' First Row Number
Const cCol As Variant = "A" ' Column Letter/Number
Const cColVal As Variant = "D" ' Value Column Letter/Number
Dim Rng As Range ' Source Found Cell Range
Dim targetCell As Range ' Cell to add hyperlink
Dim vntH As Variant ' Header Array
Dim vntC As Variant ' Color Array
Dim vntV As Variant ' Value Array
Dim vntHy As Variant ' Hyperlink Array (*)
Dim vntT As Variant ' Target Array
Dim vntTV As Variant ' Target Value Array
Dim vntTH As Variant ' Target Hyperlink
Dim i As Long ' Source/Color Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim sRow As Long ' Color Row
Dim SVal As String ' Search Value
Dim Noe As Long ' Source Number of Elements
Dim hyperlinkCounter As Long ' Counter for assigning hyperlink
' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Search for Search Value in Source Criteria Column and create
' a reference to Source Found Cell Range.
Set Rng = .Columns(cCriteriaColumn) _
.Find(SVal, , xlValues, xlWhole, , xlNext)
' Check if Search Value not found. Exit if.
If Rng Is Nothing Then Exit Sub
' Write row of Source Found Cell Range to Color Row.
sRow = Rng.Row
' Release rng variable (not needed anymore).
Set Rng = Nothing
' In Source Columns
With .Columns(cColumns)
' Copy Header Range to Header Array.
vntH = .Rows(cHeaderRow)
' Copy Color Range to Color Array.
vntC = .Rows(sRow)
' *** Copy Color Range to Value Array.
' Note: The values are also written to Color Array, but are
' later overwritten with the Color Indexes.
vntV = .Rows(sRow)
' Write number of columns in Source Columns to Source Number
' of Elements.
Noe = .Columns.Count
' Redimension
ReDim vntHy(1 To 1, 1 To Noe)
' Loop through columns of Color Range/Array.
For i = 1 To Noe
' Write current ColorIndex of Color Range to current
' element in Color Array.
vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
If .Cells(sRow, i).Hyperlinks.Count > 0 Then
vntHy(1, i) = .Cells(sRow, i).Hyperlinks(1).Address
End If
Next
End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)
' Resize target hyperlink array
ReDim vntTH(1 To Noe, 1 To 1)
' Loop through columns of Color Array.
For i = 1 To Noe
' Check if current value in Color Array is equal to Criteria
' Column Index.
If vntC(1, i) = cColorIndex Then
' Count row in Target Array.
k = k + 1
' Write value of current COLUMN in Header Array to
' element in current ROW of Target Array.
vntT(k, 1) = vntH(1, i)
' *** Write value of current COLUMN in Value Array to
' element in current ROW of Target Value Array.
vntTV(k, 1) = vntV(1, i)
' Add hyperlink to array
vntTH(k, 1) = vntHy(1, i)
End If
Next
' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Calculate Target Range by resizing the cell at the intersection of
' Target First Row and Target Column, by Number of Elements.
' Copy Target Array to Target Range.
.Cells(cFr, cCol).Resize(Noe) = vntT
' *** Calculate Target Value Range by resizing the cell at the
' intersection of Target First Row and Value Column, by Number of
' Elements.
' Copy Target Value Array to Target Value Range.
.Cells(cFr, cColVal).Resize(Noe) = vntTV
' Assign hyperlinks to cells
For Each targetCell In .Cells(cFr, cColVal).Resize(Noe)
' Remove previous hyperlinks
If targetCell.Hyperlinks.Count > 0 Then
targetCell.Hyperlinks.Item(1).Delete
End If
' Add new hyperlink
If vntTH(hyperlinkCounter + 1, 1) <> vbNullString Then
ThisWorkbook.Worksheets(cTarget).Hyperlinks.Add targetCell, vntTH(hyperlinkCounter + 1, 1)
End If
hyperlinkCounter = hyperlinkCounter + 1
Next targetCell
End With
End Sub
In general, the way you can turn a string to a Hyperlink is the following:
Sub text2Hyperlink()
Dim sht As Worksheet
Dim URL As String
Dim filePath As String
Set sht = ThisWorkbook.Worksheets("Worksheet Name") ' whichever worksheet you're working with
filePath = ".....\Something.pdf"
URL = "https://www.google.com/"
sht.Hyperlinks.Add sht.Range("A1"), filePath
sht.Hyperlinks.Add sht.Range("A2"), URL
End Sub
This takes some text stored in a string, and assigns it as a hyperlink in a cell. It works both for websites and files
In this case you end up with a link to a file in cell A1 and with a link to a webpage in cell A2.
You can modify this to suit your needs.
The task in general is to sum specific values from an Excel dataset and paste it into another Worksheet.
My idea is to nest three loops.
The first Loop Counts the Project specific number
The second Loop Counts the columns (Begins with column 'H')
The third Loop Counts the rows (Begins with row '9')
Inside this function the program sums the values related to the project number.
After it is done, the accumulated value should be pasted into
another worksheet. The cell it has to be pasted in, is the specific cell for
the project number and column.
The third loop ends when it reached the last filled row.
The second loop ends when it reached the last filled column.
The first loop ends when it reached the last predefined project number
Paste the accumulated values into another Sheet
Sum and Copy Loop
Adjust the values in the constants section to fit your needs.
The Code
Sub SumAndCopy()
' Source
Const cSheet1 As Variant = "Sheet1" ' Worksheet Name/Index
Const cCol1 As Variant = "D" ' Criteria Column Letter/Number
Const cValFirst1 As Variant = "H" ' First Value Column/Number
Const cFirstRow1 As Integer = 9 ' First Row
' Target
Const cSheet2 As Variant = "Sheet2" ' Worksheet Name/Index
Const cCol2 As Variant = "D" ' Criteria Column Letter/Number
Const cValFirst2 As Variant = "H" ' First Value Column/Number
Const cFirstRow2 As Integer = 9 ' First Row
' Both
Const cValCols As Integer = 6 ' Number of Value Columns
Dim ws1 As Worksheet ' Source Worksheet
Dim ws2 As Worksheet ' Target Worksheet
Dim lngLast1 As Long ' Source Last Used Row
Dim lngLast2 As Long ' Target Last Used Row
Dim intFirst1 As Integer ' Source First Value Column Number
Dim intFirst2 As Integer ' Target First Value Column Number
Dim i As Long ' Source Row Counter
Dim j As Integer ' Source/Target Value Column Counter
Dim k As Long ' Target Row Counter
Dim lngTemp As Long ' Value Accumulator
Set ws1 = Worksheets(cSheet1)
Set ws2 = Worksheets(cSheet2)
' Calculate Last Used Rows.
lngLast1 = ws1.Cells(ws1.Rows.Count, cCol1).End(xlUp).Row
lngLast2 = ws2.Cells(ws2.Rows.Count, cCol2).End(xlUp).Row
' Calculate First Columns.
intFirst1 = ws1.Cells(1, cValFirst1).Column
intFirst2 = ws2.Cells(1, cValFirst2).Column
' Loop through cells (rows) of Target Criteria Column.
For k = cFirstRow2 To lngLast2
' Loop through Value Columns.
For j = 1 To cValCols
lngTemp = 0 ' Reset Value Accumulator.
' Loop through cells (rows) of Source Criteria Column.
For i = cFirstRow1 To lngLast1
' Check if criterias are equal.
If ws1.Cells(i, cCol1) = ws2.Cells(k, cCol2) Then
' Add value to Val7ue Accumlator
lngTemp = lngTemp + ws1.Cells(i, j + intFirst1 - 1)
End If
Next
' Write accumulated value to current target cell.
ws2.Cells(k, j + intFirst2 - 1) = lngTemp
Next
Next
End Sub