Related
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.
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
I would like to make a macro that copies numbers that fall under the same category and add them up separately for each category. For instance Cells in column c contain the name of the product than 4 columns to the right is the number of sold products. I would like to add up all the entries in the number of sold products that fall under the same product together for each product and write it out to a predefined cell. So far I have come up with this
Sub find()
Dim XXX As Range
Dim myTotal As Long
Dim name As String
Dim name2 As String
name = Range("C2")
For Each XXX In Range("C2:C99999")
name2 = ActiveCell.Value
If name <> name2 Then
Dim aa As Integer
aa = 1
Cells(aa, 8).Value = name
Cells(aa, 9).Value = myTotal
name = name2
myTotal = 0
aa = aa + 1
End If
If InStr(XXX.Value, name2) > 0 Then
myTotal = myTotal + XXX.Offset(0, 4).Value
End If
Next XXX
End Sub
Any tips or guidelines would be appreciated and I hope the explanation makes sense.
Here's a faster basic approach:
Sub find()
Dim dict As Object, names, nums, r As Long
Dim sht As Worksheet
Set sht = ActiveSheet
Set dict = CreateObject("scripting.dictionary")
names = Range("C2:C99999").Value
nums = Range("C2:C99999").Offset(0, 4).Value
For r = 1 To UBound(names)
dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1)
Next r
WriteCounts dict, sht.Range("J1")
End Sub
Sub WriteCounts(dict As Object, rngStart As Range)
Dim k
For Each k In dict.keys
rngStart.Value = k
rngStart.Offset(0, 1).Value = dict(k)
Set rngStart = rngStart.Offset(1, 0)
Next k
End Sub
The Dictionary 'SumIf' Feature
VBA Dictionary Solution
Credits to Tim Williams and
his
solution.
Why would OP want a VBA solution when there is a perfectly good Excel
solution? When there are tens of thousands of records and as many or
many times more formulas, the workbook tends to get slow. So by adding
the SUMIF formula we're adding another bunch of them slowing down
even more. And we don't know the unique values, which we could find
using another seriously slowing down formula.
So VBA will do this in a split second, or will it? I created a new
worksheet with 60000 records and with 1000 unique ones to try to
prove it.
SumIf Solution: The first idea was to adjust all the ranges, get the unique values using Advanced Filter and then use
Worksheetfunction.SumIf. SumIf took its time, 17s, and when I
added some formulas it went above 20s.
Array Loop Solution: This one was again using Advanced Filter but this time the idea was to put everything into arrays and loop
through them and adding the values to another array one by one. This
time the loop took its time. After some tweaking it went down to 13s
and stayed there even after adding formulas.
Advanced Filter did copy the unique values in less than 0.2s into
the appropriate range, but the rest was taking too long.
Dictionary Solution: Tim Williams' solution did initially do all this in 2.5s. How is that possible I thought, Advanced Filter is the god
of unique values. Well, it isn't, or at best it is only one of them. I saw
this line in a loop in the code: dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1). It seemed like it was doing the heavy lifting in a split second which forced me to investigate (Dictionary Object (Microsoft), Excel VBA Dictionary: A Complete Guide (Paul Kelly) and produce a
solution.
The Code
Sub SumIfToTarget3() ' Array Dictionary ... 0.2-0.3s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Target
Const cTsht As Variant = "Sheet2" ' Target Worksheet Name/Index
Const cTrow As Long = 1 ' Target First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cUnique As String = "Unique" ' Unique Column Header
Const cSumIf As String = "Total" ' SumIf Column Header
' Create a reference to the Dictionary Object.
'*******************************************************
' Early Binding (0.1s Faster) *
' You have to go to Tools>References and check (create *
' a reference to) "Microsoft Scripting Runtime" . *
' Dim dict As New Dictionary ' *
'*******************************************************
'**************************************************
' Late Binding (0.1s Slower) *
' You don't need to create a reference. *
Dim dict As Object ' *
Set dict = CreateObject("Scripting.Dictionary") ' *
'**************************************************
Dim dk As Variant ' Dictionary 'Counter' (For Each Control Variable)
Dim CurV As Variant ' Current Value
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngT As Range ' Target Columns Range, Target Range
Dim vntN As Variant ' Name Array
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Name/Value Array Element (Row) Counter,
' Target Array Row Counter, Target Array Rows Count
' (Dictionary Items Count)
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Unique Column
With ThisWorkbook.Worksheets(cTsht).Columns(cUcol)
' Create a reference to Target Columns Range (rngT) i.e. the range in
' Unique Column (cUcol) from Target First Row (cTrow) to the bottom row
' of Target Worksheet (cTsht), resized by a column for SumIf Column (2).
Set rngT = .Resize(.Rows.Count - cTrow + 1, 2).Offset(cTrow - 1)
End With
' Clear contents of Target Columns Range (rngT).
rngT.ClearContents
' Write Unique Column Header to 1st Cell of Target Columns Range.
rngT.Cells(1) = cUnique
' Write SumIf Column Header to 2nd Cell of Target Columns Range.
rngT.Cells(2) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Copy Name Range (rngN) to Name Array (vntN).
vntN = rngN
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' Copy Value Range (rngV) to Value Array (vntV).
vntV = rngV
' Loop through elements (rows) of Name Array.
For i = 1 To UBound(vntN)
' Write element in current row (i) of Value Array (vntV) to Current
' Value.
CurV = vntV(i, 1)
' Check if Current Value (CurV) is NOT a number.
If Not IsNumeric(CurV) Then
' Assign 0 to Current Value.
CurV = 0
End If
' Add current element (row) in Name Array (vntN) and Current Value
' to the Dictionary. If the key to be added is new (not existing),
' the new key and the item will be added. But if the key exists, then
' the existing item will be increased by the value of the new item.
' This could be called "The Dictionary SumIf Feature".
dict(vntN(i, 1)) = dict(vntN(i, 1)) + CurV
Next
' Reset Name/Value Array Element (Row) Counter to be used as
' Target Array Row Counter.
i = 0
' Resize Target Array to the number of items in the Dictionary.
ReDim vntT(1 To dict.Count, 1 To 2)
' Loop through each Key (Item) in the Dictionary.
For Each dk In dict.Keys
' Increase Target Array Row Counter (count Target Array Row).
i = i + 1
' Write current Dictionary Key to element in current (row) and
' 1st column (Unique) of Target Array.
vntT(i, 1) = dk
' Write current Dictionary Item to element in current (row) and
' 2nd column (SumIf) of Target Array.
vntT(i, 2) = dict(dk)
Next
' Calculate Target Range (rngT) from second row (2) of Target Columns
' Range (rngT) resized by Target Array Rows Count (i).
Set rngT = rngT.Rows(2).Resize(i)
' Copy Target Array (vntT) to Target Range (rngT).
rngT = vntT
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
SUMIF?! An Excel Solution
This is more a question than an answer:
Could this be regarded as a simplified visual presentation of what you are trying to achieve?
You can use the following formula in cell I2:
=SUMIF(C$2:C$16,H2,G$2:G$16)
Adjust the ranges and copy down.
Advanced Filter Array Loop Solution
Sub SumIfToUnique2() ' Advanced Filter & Loop through Arrays, Add ... 13s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Unique
Const cUsht As Variant = "Sheet2" ' Unique Worksheet Name/Index
Const cUrow As Long = 1 ' Unique First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cSumIf As String = "Total" ' SumIf Column Header
Const cUnique As String = "Unique" ' Unique Column Header
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngU As Range ' Unique Column Range, Last Used Cell in Unique Column,
' Unique Range
Dim vntN As Variant ' Name Array
Dim vntV As Variant ' Value Array
Dim vntU As Variant ' Unique Array
Dim vntS As Variant ' SumIf Array
Dim i As Long ' Name/Value Array Row Counter
Dim k As Long ' Unique/SumIf Array Row Counter
Dim strN As String ' Current Name (in Name Array)
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Create a reference to Name Column Range (rngN) i.e. the range in
' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
' of Name Worksheet (cNsht).
Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
End With
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Create a reference to Unique Column Range (rngU) i.e. the range in
' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
' of Unique Worksheet (cUsht).
Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
End With
' Clear contents of Unique Column Range (rngU).
rngU.ClearContents
' Calculate SumIf Column Range.
' Clear contents of SumIf Column Range.
rngU.Offset(, 1).ClearContents
' Write unique values from Name Column Range (rngN), starting with the
' header (aka title), to Unique Column Range (rngU), starting in its
' First Row (1).
rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
' Calculate Unique Header Cell Range.
' Write Unique Column Header to Unique Header Cell Range.
rngU.Resize(1) = cUnique
' Calculate SumIf Header Cell Range.
' Write SumIf Column Header to SumIf Header Cell Range.
rngU.Resize(1).Offset(, 1) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Copy Name Range (rngN) to Name Array (vntN).
vntN = rngN
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' Copy Value Range (rngV) to Value Array (vntV).
vntV = rngV
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Calculate Last Used Cell in Unique Column.
Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Unique Range with headers.
Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
End With
' Calculate Unique Range (without headers).
Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
' Copy Unique Range (rngU) to Unique Array (vntU).
vntU = rngU
' Resize SumIf Array to size of Unique Array.
ReDim vntS(1 To UBound(vntU), 1 To 1)
' Loop through elements (rows) of Name Array.
For i = 1 To UBound(vntN)
' Write current value in Name Array (vntN) to Current Name (strN).
strN = vntN(i, 1)
' Loop through elements (rows) of Unique/SumIf Array.
For k = 1 To UBound(vntU)
If vntU(k, 1) = strN Then
vntS(k, 1) = vntS(k, 1) + vntV(i, 1)
Exit For
End If
Next
Next
' Calculate SumIf Range (from Unique Range (rngU)).
' Copy SumIf Array to SumIf Range.
rngU.Offset(, 1) = vntS
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
Advanced Filter SumIf Solution
Sub SumIfToUnique1() ' Advanced Filter & SumIf on Ranges ... 17-22s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Unique
Const cUsht As Variant = "Sheet2" ' Unique Worksheet Name/Index
Const cUrow As Long = 1 ' Unique First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cSumIf As String = "Total" ' SumIf Column Header
Const cUnique As String = "Unique" ' Unique Column Header
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngU As Range ' Unique Column Range, Last Used Cell in Unique Column,
' Unique Range
Dim vntU As Variant ' Unique Array
Dim vntS As Variant ' SumIf Array
Dim i As Long ' Unique Array Row Counter
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Create a reference to Name Column Range (rngN) i.e. the range in
' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
' of Name Worksheet (cNsht).
Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
End With
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Create a reference to Unique Column Range (rngU) i.e. the range in
' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
' of Unique Worksheet (cUsht).
Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
End With
' Clear contents of Unique Column Range (rngU).
rngU.ClearContents
' Calculate SumIf Column Range.
' Clear contents of SumIf Column Range.
rngU.Offset(, 1).ClearContents
' Write unique values from Name Column Range (rngN), starting with the
' header (aka title), to Unique Column Range (rngU), starting in its
' First Row (1).
rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
' Calculate Unique Header Cell Range.
' Write Unique Column Header to Unique Header Cell Range.
rngU.Resize(1) = cUnique
' Calculate SumIf Header Cell Range.
' Write SumIf Column Header to SumIf Header Cell Range.
rngU.Resize(1).Offset(, 1) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Calculate Last Used Cell in Unique Column.
Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Unique Range with headers.
Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
End With
' Calculate Unique Range (without headers).
Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
' Copy Unique Range to Unique Array.
vntU = rngU
' Resize SumIf Array to size of Unique Array.
ReDim vntS(1 To UBound(vntU), 1 To 1)
' Loop through elements (rows) of SumIf/Unique Array.
For i = 1 To UBound(vntS)
' Write result of SumIf funtion to current element (row) of SumIf Array.
vntS(i, 1) = WorksheetFunction.SumIf(rngN, vntU(i, 1), rngV)
Next
' Calculate SumIf Range (from Unique Range (rngU)).
' Copy SumIf Array to SumIf Range.
rngU.Offset(, 1) = vntS
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
What I exactly need is to get the first 3 words out of each cell of the range selected, and then set it in the same place (each cell), so that I end up with the first 3 words in each cell. It doesn´t matter the number of words there were before. Basically, I need a code with a bucle to do that with each cell in the selection.
I´ve tried to use formula local, but it doesn´t work.
Sub EXTRAER_NOMBRES_Y_APELLIDO()
'Convierte los textos seleccionados a formato de nombre propio
'La primera letra en mayúscula y el resto en minúsculas
'Dim CELDA As String
'Dim B As Integer
For Each CELDA In Selection
'CELDA.Value = Left(Range("Y3"), 5)
'Range("Y3") = Left(Range("Y3"), 5)
'CELDA.Value = Left(CELDA, 3)
ActiveCell.FormulaLocal = "=LEFT(Planilla[#Estudiante];FIND(" ";Planilla[#Estudiante])-1)"
Next CELDA
End Sub
What I expect is to get the first 3 words in each cell of the column (range previously selected).
Split Names
Assumptions
There are two or three names per cell range (person):
First Name and Last Name or
First Name, Middle Name and Last Name.
You wanted the names from one column split into three columns.
The Code
Adjust the values in the constants section to fit your needs.
You can choose the same column letter or number if you want to
overwrite the initial data, but do this after testing the code.
Sub SplitNames()
Const cSource As Variant = "A" ' Source Column Letter/Number
Const cTarget As Variant = "B" ' Target Column Letter/Number
Const cFirstR As Long = 2 ' Source/Target First Row Number
Dim vntS As Variant ' Source Array
Dim vntD As Variant ' Delimited Array
Dim vntT As Variant ' Target Array
Dim LastR As Long ' Source/Target Last Row Number
Dim i As Long ' Source/Target Array Row Counter
' Calculate Source/Target Last Row Number.
LastR = Cells(Rows.Count, cSource).End(xlUp).Row
' Copy Source Range into Source Array.
vntS = Range(Cells(cFirstR, cSource), Cells(LastR, cSource))
' Resize Target Array's rows to the number of rows in Source Array,
' but to three columns: First, Middle, Last.
ReDim vntT(1 To UBound(vntS), 1 To 3)
' Copy from Source Array to Target Array.
For i = 1 To UBound(vntS) ' Rows of Source/Target Array
vntD = Split(vntS(i, 1)) ' Split each row of Source Array.
vntT(i, 1) = vntD(0) ' First Name
If UBound(vntD) = 2 Then ' Does have middle name.
vntT(i, 2) = vntD(1) ' Middle Name
vntT(i, 3) = vntD(2) ' Last Name
Else ' Does not have middle name.
vntT(i, 3) = vntD(1) ' Last Name
End If
Next
' Copy Target Array into Target Range.
Range(Cells(cFirstR, cTarget), Cells(LastR, cTarget)) _
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End Sub
Second Version
Adjust the values in the constants section to fit your needs.
You can choose the same column letter or number if you want to
overwrite the initial data, but do this after testing the code.
Sub SplitNames2()
Const cSource As Variant = "A" ' Source Column Letter/Number
Const cTarget As Variant = "B" ' Target Column Letter/Number
Const cFirstR As Long = 7 ' Source/Target First Row Number
Const cNum As Long = 3 ' Number of Words
Dim vntS As Variant ' Source Array
Dim vntD As Variant ' Delimited Array
Dim vntT As Variant ' Target Array
Dim LastR As Long ' Source/Target Last Row Number
Dim i As Long ' Source/Target Array Row Counter
Dim j As Long ' Delimited Array Rows Counter
' Calculate Source/Target Last Row Number.
LastR = Cells(Rows.Count, cSource).End(xlUp).Row
' Copy Source Range into Source Array.
vntS = Range(Cells(cFirstR, cSource), Cells(LastR, cSource))
' Resize Target Array's rows to Source Array,
ReDim vntT(1 To UBound(vntS), 1 To 1)
' Copy from Source Array to Target Array.
For i = 1 To UBound(vntS) ' Rows of Source/Target Array
vntD = Split(vntS(i, 1)) ' Split each row of Source Array.
j = UBound(vntD)
If j > cNum - 1 Then
j = cNum - 1
End If
If j <> -1 Then
For j = 0 To j
If j > 0 Then
vntT(i, 1) = vntT(i, 1) & " " & vntD(j)
Else
vntT(i, 1) = vntD(j)
End If
Next
End If
Next
' Copy Target Array into Target Range.
Range(Cells(cFirstR, cTarget), Cells(LastR, cTarget)) = vntT
End Sub
This is a proposal, using basic Excel formulas:
Replace the first space with an underscore
Replace the first space with an underscore (as a result, both first spaces are replaced by underscore)
Determine the location of the first space (which gives the location of the third space in the original text)
Take the text, at the left of the nth character.
Hereby the formulas (the original text is in cell B2):
B3 : =SUBSTITUTE(B2;" ";"_";1)
B4 : =SUBSTITUTE(B3;" ";"_";1)
B5 : =FIND(" ";B4)
B6 : =LEFT(B2;B5-1)
I have a problem I need help with involving Excel and VBA. I know next to nothing about Excel/VBA, and I need a coding solution to help me avoid performing the extremely tedious task of doing this manually (think hundreds of lines that need to be parsed where one row could become multiple rows in a new sheet). I've been searching the web for solutions, but I just keep getting confused by the answers (because I don't know anything about VB and using it to program a macro in Excel), so I figured I'd seek help for my specific problem.
Here is the rundown: I have a spreadsheet where I need to copy rows from a source sheet to a target sheet. The source sheet has 2 columns (A & B) that can be thought of as a key/value pair where col A contains the key and col B contains the value. The problem lies with the values in col B. The values can either be a single line of text or a numbered list of different texts
What I want to do is for each row in the source:
split the values in col B to get an array of each individual value (if the value is in the form of a numbered list)
create new rows in the target sheet by looping over the split array of values such that a new row will be created where:
new row col A = source row col A key and new row col B = current iteration index from the array of split values.
if no numbered list, just copy the source row into target sheet
Source
A B
key1 1. text1
2. text2
key2 1. text3
Target
A B
key1 text1
key1 text2
key2 text3
The numbered list in a cell will be multiple lines where each line of text is prepended by a decimal and a dot. This applies to single line cells as well.
(Update) Bear in mind that the values in either col A or B are not simple text values. These are full on sentences. So, I'm not sure a simple formula is going to work.
Split Multi Line
It is unclear which line separator occurs in the multi line cells. Choose one, vbLf worked for me.
Adjust the values in the constants section to fit your needs.
The Code
Sub SplitMultiLine()
Const cSheet1 As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cFirstR As Integer = 1 ' Source First Row Number
Const cFirstC As Variant = "A" ' Source First Column Letter/Number
Const cLastC As Variant = "C" ' Source Last Column Letter/Number
Const cMulti As Integer = 2 ' Multi Column
Const cSplit As String = vbLf ' Split Char(vbLf, vbCrLf, vbCr)
Const cDot As String = "." ' Dot Char (Delimiter)
Const cSheet2 As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTarget As String = "E1" ' Target First Cell Address
Dim vntS As Variant ' Source Array
Dim vntSplit As Variant ' Split Array
Dim vntT As Variant ' Target Array
Dim lastR As Long ' Source Last Row
Dim i As Long ' Source Array Row Counter
Dim j As Integer ' Source/Target Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Integer ' Split Array Row Counter
' Paste Source Range into Source Array.
With Worksheets(cSheet1)
lastR = .Cells(.Rows.Count, cFirstC).End(xlUp).Row
vntS = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR, cLastC))
End With
' Count the number of rows in target array.
For i = 1 To UBound(vntS)
k = k + UBound(Split(vntS(i, cMulti), cSplit)) + 1
Next
' Write from Source to Target Array.
ReDim vntT(1 To k, 1 To UBound(vntS, 2))
k = 0
For i = 1 To UBound(vntS)
k = k + 1
vntSplit = Split(vntS(i, cMulti), cSplit)
For m = 0 To UBound(vntSplit)
If InStr(vntSplit(m), cDot) > 0 Then
vntT(k, cMulti) = Trim(Right(vntSplit(m), Len(vntSplit(m)) _
- InStr(vntSplit(m), cDot)))
Else
vntT(k, cMulti) = vntSplit(m)
End If
For j = 1 To UBound(vntS, 2)
If j <> cMulti Then
vntT(k, j) = vntS(i, j)
End If
Next
k = k + 1
Next
k = k - 1
Next
' Paste Target Array into Target Range calculated from Target Frist Cell.
With Worksheets(cSheet2).Range(cTarget)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
An Over-Commenting
Sub SplitMultiLineOverCommented()
Const cSheet1 As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cFirstR As Integer = 1 ' Source First Row Number
Const cFirstC As Variant = "A" ' Source First Column Letter/Number
Const cLastC As Variant = "C" ' Source Last Column Letter/Number
Const cMulti As Integer = 2 ' Multi Column
Const cSplit As String = vbLf ' Split Char(vbLf, vbCrLf, vbCr)
Const cDot As String = "." ' Dot Char (Delimiter)
Const cSheet2 As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTarget As String = "E1" ' Target First Cell Address
Dim vntS As Variant ' Source Array
Dim vntSplit As Variant ' Split Array
Dim vntT As Variant ' Target Array
Dim lastR As Long ' Source Last Row
Dim i As Long ' Source Array Row Counter
Dim j As Integer ' Source/Target Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Integer ' Split Array Row Counter
' Paste Source Range into Source Array.
With Worksheets(cSheet1)
' The last row of data is usually calculated going from the bottom up,
' it is like selecting the last cell and pressing CTRL UP and returning
' =ROW() in Excel.
lastR = .Cells(.Rows.Count, cFirstC).End(xlUp).Row
' Paste a range into an array actually means copying it. The array
' created is a 1-based 2-dimensional array which has the same number
' of rows and columns as the Source Range.
vntS = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR, cLastC))
End With
' Count the number of rows in Target Array.
' You refer to the last row of the array with UBound(vntS) which is short
' for UBound(vntS, 1) which reveals that it is referring to the first
' dimension (rows).
For i = 1 To UBound(vntS)
' We are splitting the string by cSplit which is the line
' separator (delimiter). When you enter something into a cell and
' hold left Alt and press ENTER, the vbLf character is set in place
' of the line separator. But the data may have been imported from
' another system that uses another line separator. When splitting the
' string, a 0-based array is 'created' and its UBound is the last
' row, but since it is 0-based we have to add 1.
k = k + UBound(Split(vntS(i, cMulti), cSplit)) + 1
Next
' Write from Source to Target Array.
' After we have calculated the number of rows, we have to resize the
' Target Array. To avoid confusion, I always use '1 To' to be certain that
' it is a 1-based array. Since the number columns of the Source Array and
' the Target Array is the same, we use the UBound of the Source Array to
' resize the second dimension of the Target Array - UBound(vntS, 2) where
' 2 is indicating the second dimension, columns.
ReDim vntT(1 To k, 1 To UBound(vntS, 2))
' We will use again k as the row counter since its value is no more
' needed. This is what I have many times forgotten, so maybe it is
' better to use a different variable.
k = 0
' Loop through the columns of Source Array.
For i = 1 To UBound(vntS)
' Increase the row of Target Array or e.g. align it for writing.
k = k + 1
' Split the string (lines) in the Multi Column into the 0-based
' Split Array.
vntSplit = Split(vntS(i, cMulti), cSplit)
' Loop through the values of the Split Array
For m = 0 To UBound(vntSplit)
' Check if value contains cDot. The Instr function returns 0 if
' a string has not been found, it's like =FIND(".",A1) in Excel,
' except that Excel would return an error if not found.
If InStr(vntSplit(m), cDot) > 0 Then
' If cDot was found then write the right part after cDot
' to the current row of column cMulti but trim the result
' (remove space before and after.
' It's like =TRIM(RIGHT(A1,LEN(A1)-FIND(".",A1))) in Excel.
vntT(k, cMulti) = Trim(Right(vntSplit(m), Len(vntSplit(m)) _
- InStr(vntSplit(m), cDot)))
Else
' If cDot was not found then just write the value to the
' current row.
vntT(k, cMulti) = vntSplit(m)
End If
' Loop through all columns.
For j = 1 To UBound(vntS, 2)
If j <> cMulti Then
' Write to other columns (Not cMulti)
vntT(k, j) = vntS(i, j)
End If
Next ' Next Source/Target Array Column
' Increase the current row of Target Array before going to next
' value in Split Array.
k = k + 1
Next ' Next Split Array Row
' Since we have increased the last current row but haven't written to
' it, we have to decrease one row because of the "k = k + 1" right below
' "For i = 1 To UBound(vntS)" which increases the row of Target Array
' for each next row in Source Array.
k = k - 1
Next ' Next Source Array Row
' Paste Target Array into Target Range calculated from Target Frist Cell.
' Like we pasted a range into an array, we can also paste an array into
' a range, but it has to be the same size as the array, so by using
' the Resize method we adjust the Target Range First Cell to the Target
' Range, using the last row and column of the Target Array. Again,
' remember UBound(vntT) is short for UBound(vntT, 1) (rows).
With Worksheets(cSheet2).Range(cTarget)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
You can do this with two formulas.
I'm assuming your data is in Sheet1.
For the first columns, use the following formula:
=IF(ISBLANK(Sheet1!A2),A1,Sheet1!A2)
For the second one use:
=IFERROR(RIGHT(Sheet1!B2,LEN(Sheet1!B2)-FIND(". ",Sheet1!B2)-1),Sheet1!B2)
And populate down.
edit:
The first formula will look at the corresponding cell in Sheet1, column A. If it is blank, it will take the value of the cell above where the formula is. If it isn't blank, it will take the value of the cell in Sheet1, column A that it just checked.
The second formula looks for the string ". " in the cells in Sheet1 column B and removes it and everything to the left of it from the text. If the string in question (". ") is not found (meaning there is no numbering in that given cell) it would return an error, so the whole thing is wrapped in an IFERROR statement which returns the value of the cell in Sheet1 column B if it is triggered.