How would I go about distributing the contents of a cell in excel across a specified range based on a defined factor?
E.g. Cell A1 contains 1,2,3,4,5,6,7,8,9
The desired result is to spread that series over the range A1:A9
Or a more complex example: A1 contains apple, orange; 34; 67, "pod"
The desired result is to spread the contents separated by the differing punctuation over the range B1:F1
Thanks.
Use Data -> Text to Columns to do this:
http://www.excel-easy.com/examples/text-to-columns.html
In VBA
Option Explicit
Public Sub SpreadListsInColA()
Dim c As Range, itms As Variant
With Sheet1.UsedRange.Columns("A")
Application.ScreenUpdating = False
For Each c In .Cells
If Not IsError(c) Then
If Len(c.Value2) > 0 And InStr(c.Value2, ",") > 0 Then
itms = Split(c.Value2, ",")
c.Offset(, 1).Resize(, UBound(itms) + 1) = itms
End If
End If
Next
Application.ScreenUpdating = True
End With
End Sub
This UDF will almost deal with the first scenario. As it's a function then the original text will remain in cell A1 and this will distribute over the cells you've entered the formula in.
In A2:A10 or A2:I2 enter this array formula: =Transpose_Ext(A1,",")
Public Function Transpose_Ext(Source As Range, Delim As String) As Variant
With Application.Caller
If Source.Cells.Count = 1 Then
If .Rows.Count = 1 Then
Transpose_Ext = Array(Split(Source, Delim))
ElseIf .Rows.Count > 1 And .Columns.Count = 1 Then
Transpose_Ext = Application.WorksheetFunction.Transpose(Array(Split(Source, Delim)))
End If
End If
End With
End Function
To use multiple delimiters I'd add a paramarray as the last argument in the function to store an array of delimiters and then something to split the source value by each delimiter.
Edit: But, as already mentioned, text to columns and the Transpose function will do the job just as well.
Related
I want to merge cells in one row (belongs to Column B) with the count of already merged different cell(belongs to Column A) .How can i start coding ?
this is the screenshot that i want
Merging cells in a spreadsheet means taking two or more cells and
constructing a single cell out of them. When you merge two or more
adjacent horizontal or vertical cells, the cells become one larger
cell that is displayed across multiple columns or rows. When you
merge multiple cells, the contents of only one cell (the upper-left
cell for left-to-right languages, or the upper-right cell for
right-to-left languages) appear in the merged cell. The contents of
the other cells that you merge are deleted. For more details please
go through this MSDN article Merge and unmerge
cells
Simple VBA code for Merging Cell
Sub merg_exp_1()
ActiveSheet.Range("A1:C10").Merge
End Sub
Sample data before and after running the program is shown.
Now let us see, If we merge a row what happens. Sample code for this
exercise though general is being tested for one situation only and
it as follow :
Sub Merge_Rows()
Dim rng As Range
Dim rrow As Range
Dim rCL As Range
Dim out As String
Dim dlmt As String
dlmt = ","
Set rng = ActiveSheet.Range("A1:C5")
For Each rrow In rng.Rows
out = ""
For Each rCL In rrow.Cells
If rCL.Value <> "" Then
out = out & rCL.Value & dlmt
End If
Next rCL
Application.DisplayAlerts = False
rrow.Merge
Application.DisplayAlerts = True
If Len(rrow.Cells(1).Value) > 0 Then
rrow.Cells(1).Value = Left(out, Len(out) - 1)
End If
Next rrow
End Sub
Sample data before and after running the program is shown. You can see this won't meet your objective.
Next we can try merging by column approach. Here also we are trying
for one column i.e. Column B to see the effect. Sample code as
follows.
Sub Merge_col_exp()
Dim cnum As Integer
Dim rng As Range
Dim str As String
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
cnum = Cells(i, 1).MergeArea.Count
Set rng = Range(Cells(i, 2), Cells(i - cnum + 1, 2)) ' only to demonstrate working in 2nd column
For Each cl In rng
If Not IsEmpty(cl) Then str = str + "," + cl
Next
If str <> "" Then str = Right(str, Len(str) - 1)
Application.DisplayAlerts = False
rng.Merge
rng = str
Application.DisplayAlerts = True
str = ""
i = i - cnum + 1
Next i
End Sub
Sample data before and after running the program is shown. You can see this is closer to your requirement. You can extend functionality of this program by finding Last Column in the Actively used range. Extend program functionality to cover upto last column.
My problem:
I've made a large (2,000 line) macro that runs on our company's template and fixes some common issues and highlights other issues we have prior to importing. The template file always has 150 columns and is in most instances 15,000+ rows (sometimes even over 30,000). The macro works well, highlighting all the cells that contain errors according to our data rules, but with a file with so many columns and rows I thought it'd be convenient to add a snippet to my macro that would have it find all of the cells that have been highlighted and then highlight the column headers of the columns that contain those highlighted cells.
Methods I've found while searching for a solution:
SpecialCellsxlCellTypeAllFormatConditions only works for conditional formatting, so that isn't a plausible method for my situation
Rick Rothstein's UDF from here
Sub FindYellowCells()
Dim YellowCell As Range, FirstAddress As String
Const IndicatorColumn As String = "AK"
Columns(IndicatorColumn).ClearContents
' The next code line sets the search for Yellow color... the next line after it (commented out) searches
' for the ColorIndex 6 (which is usually yellow), so use whichever code line is applicable to your situation
Application.FindFormat.Interior.Color = vbYellow
'Application.FindFormat.Interior.ColorIndex = 6
Set YellowCell = Cells.Find("*", After:=Cells(Rows.Count, Columns.Count), SearchFormat:=True)
If Not YellowCell Is Nothing Then
FirstAddress = YellowCell.Address
Do
Cells(YellowCell.Row, IndicatorColumn).Value = "X"
Set YellowCell = Cells.Find("*", After:=YellowCell, SearchFormat:=True)
If YellowCell Is Nothing Then Exit Do
Loop While FirstAddress <> YellowCell.Address
End If
End Sub
This would be perfect with a few tweaks, except our files can have multiple colorfills. Since our template is so large I've learned that it takes quite some time to run one instance of Find to find just one colorfill in the UsedRange.
Using filtering, maybe cycling through all the columns and checking each if they contain any cell that has any colorfill. Would that be any faster though?
So, my question:
How could I accomplish finding all columns that contain any colorfilled cells? More specifically, what would be the most efficient (fastest) way to achieve this?
The most performant solution would be to search using recursion by half-interval.
It takes less than 5 seconds to tag the columns from a worksheet with 150 columns and 30000 rows.
The code to search for a specific color:
Sub TagColumns()
Dim headers As Range, body As Range, col As Long, found As Boolean
' define the columns for the headers and body
Set headers = ActiveSheet.UsedRange.Rows(1).Columns
Set body = ActiveSheet.UsedRange.Offset(1).Columns
' iterate each column
For col = 1 To headers.Count
' search for the yellow color in the column of the body
found = HasColor(body(col), vbYellow)
' set the header to red if found, green otherwise
headers(col).Interior.color = IIf(found, vbRed, vbGreen)
Next
End Sub
Public Function HasColor(rg As Range, color As Long) As Boolean
If rg.DisplayFormat.Interior.color = color Then
HasColor = True
ElseIf VBA.IsNull(rg.DisplayFormat.Interior.colorIndex) Then
' The color index is null so there is more than one color in the range
Dim midrow&
midrow = rg.Rows.Count \ 2
If HasColor(rg.Resize(midrow), color) Then
HasColor = True
ElseIf HasColor(rg.Resize(rg.Rows.Count - midrow).Offset(midrow), color) Then
HasColor = True
End If
End If
End Function
And to search for any color:
Sub TagColumns()
Dim headers As Range, body As Range, col As Long, found As Boolean
' define the columns for the headers and body
Set headers = ActiveSheet.UsedRange.Rows(1).Columns
Set body = ActiveSheet.UsedRange.Offset(1).Columns
' iterate each column
For col = 1 To headers.Count
' search for any color in the column of the body
found = VBA.IsNull(body(col).DisplayFormat.Interior.ColorIndex)
' set the header to red if found, green otherwise
headers(col).Interior.color = IIf(found, vbRed, vbGreen)
Next
End Sub
Before:
Running this short macro:
Sub FindingColor()
Dim r1 As Range, r2 As Range, r As Range
Dim nFirstColumn As Long, nLastColumn As Long, ic As Long
Set r1 = ActiveSheet.UsedRange
nLastColumn = r1.Columns.Count + r1.Column - 1
nFirstColumn = r1.Column
For ic = nFirstColumn To nLastColumn
Set r2 = Intersect(r1, Columns(ic))
For Each r In r2
If r.Interior.ColorIndex <> xlNone Then
r2(1).Interior.ColorIndex = 27
Exit For
End If
Next r
Next ic
End Sub
produces:
I just don't know about the speed issue. If the colored cells are near the top of the column, the code will run super fast; if the colored cells are missing or near the bottom of the column, not so much.
EDIT#1:
Please note that my code will not find cells colored conditionally.
The Range.Value property actually has three potential optional xlRangeValueDataType parameters. The default is xlRangeValueDefault and that is all (by omission) most anyone ever uses.
The xlRangeValueXMLSpreadsheet option retrieves an XML data block which describes many of the properties that the cell maintains. A cell with no Range.Interior property beyond xlAutomatic will have the following XML element,
<Interior/>
... while a cell with an .Interior.Color property will have the following XML element,
<Interior ss:Color="#FF0000" ss:Pattern="Solid"/>
It's been well established that dumping a worksheet's values into a variant array and processing in-memory is substantially quicker than looping through cells so retrieving the .Value(xlRangeValueXMLSpreadsheet) and performing an InStr function on the single blob of XML data should prove much faster.
Sub filledOrNot()
Dim c As Long, r As Long, vCLRs As String
appTGGL bTGGL:=False
With Worksheets("30Kdata")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
For c = 1 To .Columns.Count
vCLRs = .Columns(c).Cells.Value(xlRangeValueXMLSpreadsheet)
If CBool(InStr(1, vCLRs, "<Interior ss:Color=", vbBinaryCompare)) Then _
.Cells(0, c).Interior.Color = 49407
Next c
End With
End With
Debug.Print Len(vCLRs)
End With
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
I ran this against 30K rows by 26 columns. While each column was examined, I had only seeded every third column with an .Interior.Color property somewhere randomly within the 30K rows. It took about a minute and a half.
Each column of 30K rows produced an XML record that was almost 3Mbs in size; a length of 2,970,862 was typical. Once read into a variable, it was searched for the fingerprint of a set interior fill.
Discarding the read into the string type var and performing the InStr directly on the .Value(xlRangeValueXMLSpreadsheet) actually improved the time by about two seconds.
My proposal using AutoFilter method of Range object
it runs quite fast
Option Explicit
Sub FilterByFillColor()
Dim ws As Worksheet
Dim headerRng As Range
Dim iCol As Long, RGBColor As Long
Set ws = ThisWorkbook.Worksheets("HeadersToColor") '<== set it to your actual name of the data worksheet
Set headerRng = ws.Range("headers") '<== I set a named range "headers" in my test sheet addressing the cells that cointains all headers. but you may use explicit address ie: 'ws.Range("B2:EU150")' for a 150 columns header range
RGBColor = RGB(255, 0, 0)
Application.ScreenUpdating = False
headerRng.Interior.Color = vbGreen
With headerRng.CurrentRegion
For iCol = 1 To .Columns.Count
.AutoFilter Field:=iCol, Criteria1:=RGBColor, Operator:=xlFilterNoFill
If .Columns(iCol).SpecialCells(xlCellTypeVisible).Count < .Rows.Count Then headerRng(iCol).Interior.Color = vbRed
.AutoFilter
Next iCol
End With
Application.ScreenUpdating = True
End Sub
I am new to this. I am trying to find the lowest value in a cell with multiple values inside. For example,
48
44.50
41.00
37.50
I am trying to find 37.50. What should be the code for it?
Thanks
Based on your posted example:
Sub FindMin()
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = ActiveCell.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
MsgBox wf.Min(bry)
End Sub
This assumes that there is a hard return (ASCII-10) between the fields in the cell.
EDIT#1:
To make it into a function, remove the sub and replace with:
Public Function FindMin(r As Range) As Variant
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = r.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
FindMin = wf.Min(bry)
End Function
EDIT#2:
based on your comment, here is an example of input vs output:
Note that all the values are in a single cell and the values are separated by hard returns rather than spaces.
By code with same cell and a " " as delimiter to break
temp = Range("A1").Value
temp = Split(temp, " ")
Low = CInt(temp(0))
For i = 0 To UBound(temp) - 1
If CInt(temp(i)) < Low Then Low = CInt(temp(i))
Next
Range("a2").Value = Low
if they are in a range you can use a formula
=MIN(A1:A4)
This question is pretty close to one previously asked:
VBA/EXCEL: extract numbers from one cell that contained multiple values with comma
If you take the code from that answer and replace the comma with whatever is separating your values, you will be able to get access to them in VBA. Then you can write code to find the minimum.
You can make a macro to split the values for each cell you selected and then check for the highest value. And a quick check to make sure you are not parsing all the empty rows (when you selected a column).
The macro below will set the highest value in the next column.
Sub lowest()
Dim Values As Variant
Dim LowestValue As Double
Dim a As Range
Set a = Selection
For Each Row In a.Rows
For Each Cell In Row.Cells
LowestValue = -1
Values = Split(Cell.Value, Chr(10))
For Each Value In Values
If LowestValue = -1 Then
LowestValue = Value
ElseIf Value < LowestValue Then
LowestValue = Value
End If
Next
Cells(Cell.Row, Cell.Column + 1).Value = LowestValue
If IsEmpty(Cell.Value) Then GoTo EndLoop
Next Cell
Next Row
EndLoop:
End Sub
I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:
If (A1 < 350) and (B1 has the same color as a reference cell), then count 1.
Loop over rows 1 to 15
It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html
Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!
=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))
The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.
'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim CallerCols As Long 'find out the number of cells input by the user
'so as to define the correct array size
With Application.Caller
CallerCols = .Column.Count
End With
ReDim TFresponses(1 To CallerCols)
Dim Idx As Long
Idx = 1
For Each rCell In compareCells
If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
TFresponses(Idx) = 1
Idx = Idx + 1
Else
TFresponses(Idx) = 0
Idx = Idx + 1
End If
Next rCell
ColorCompare = TFresponses
End Function
There are a couple of issues in your code
You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make
Here's a refactored version of your Function
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range, rRw As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim rw As Long, cl As Long
Dim clr As Variant
clr = refCell.Interior.ColorIndex
ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)
rw = 1
For Each rRw In compareCells.Rows
cl = 1
For Each rCell In rRw.Cells
If rCell.Interior.ColorIndex = clr Then
TFresponses(rw, cl) = True
End If
cl = cl + 1
Next rCell
rw = rw + 1
Next rRw
ColorCompare = TFresponses
End Function
Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.
Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):
Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub
I have one excel file with multiple sheets.
I need to compare two sheets (1) TotalList and (2) cList with more than 25 columns, in these two sheets columns are same.
On cList the starting row is 3
On TotalList the starting row is 5
Now, I have to compare the E & F columns from cList, with TotalList E & F columns, if it is not found then add the entire row at the end of TotalList sheet and highlight with Yellow.
Public Function compare()
Dim LoopRang As Range
Dim FoundRang As Range
Dim ColNam
Dim TotRows As Long
LeaData = "Shhet2"
ConsolData = "Sheet1"
TotRows = Worksheets(LeaData).Range("D65536").End(xlUp).Row
TotRows1 = Worksheets(ConsolData).Range("D65536").End(xlUp).Row
'TotRows = ThisWorkbook.Sheets(LeaData).UsedRange.Rows.Count
ColNam = "$F$3:$F" & TotRows
ColNam1 = "$F$5:$F" & TotRows1
For Each LoopRang In Sheets(LeaData).Range(ColNam)
Set FoundRang = Sheets(ConsolData).Range(ColNam1).Find(LoopRang, lookat:=xlWhole)
For Each FoundRang In Sheets(ConsolData).Range(ColNam1)
If FoundRang & FoundRang.Offset(0, -1) <> LoopRang & LoopRang.Offset(0, -1) Then
TotRows = Worksheets(ConsolData).Range("D65536").End(xlUp).Row
ThisWorkbook.Worksheets(LeaData).Rows(LoopRang.Row).Copy ThisWorkbook.Worksheets(ConsolData).Rows(TotRows + 1)
ThisWorkbook.Worksheets(ConsolData).Rows(TotRows + 1).Interior.Color = vbYellow
GoTo NextLine
End If
Next FoundRang
NextLine:
Next LoopRang
End Function
Please help with the VBA code.
Thanks in advance...
First I am going to give some general coding hints:
set Option Explicit ON. This is done through Tools > Options >
Editor (tab) > Require Variable Declaration . Now you HAVE to
declare all variables before you use them.
always declare a variables type when you declare it. If you are unsure about what to sue or if it can take different types (not advisable!!) use Variable.
Use a standard naming convention for all your variables. Mine is a string starts with str and a double with dbl a range with r, etc.. So strTest, dblProfit and rOriginal. Also give your variables MEANINGFUL names!
Give your Excel spreadsheets meanigful names or captions (caption is what you see in excel, name is the name you can directly refer to in VBA). Avoid using the caption, but refer to the name instead, as users can change the caption easily but the name only if they open the VBA window.
Ok so here is how a comparison between two tables can be done with your code as starting point:
Option Explicit
Public Function Compare()
Dim rOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim rTableOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rTableFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim shOriginal As Worksheet
Dim shFind As Worksheet
Dim booFound As Boolean
'Initiate all used objects and variables
Set shOriginal = ThisWorkbook.Sheets("Sheet2")
Set shFind = ThisWorkbook.Sheets("Sheet1")
Set rTableOriginal = shOriginal.Range(shOriginal.Rows(3), shOriginal.Rows(shOriginal.Rows.Count).End(xlUp))
Set rTableFind = shFind.Range(shFind.Rows(5), shFind.Rows(shFind.Rows.Count).End(xlUp))
booFound = False
For Each rOriginal In rTableOriginal.Rows
booFound = False
For Each rFind In rTableFind.Rows
'Check if the E and F column contain the same information
If rOriginal.Cells(1, 5) = rFind.Cells(1, 5) And rOriginal.Cells(1, 6) = rFind.Cells(1, 6) Then
'The record is found so we can search for the next one
booFound = True
GoTo FindNextOriginal 'Alternatively use Exit For
End If
Next rFind
'In case the code is extended I always use a boolean and an If statement to make sure we cannot
'by accident end up in this copy-paste-apply_yellow part!!
If Not booFound Then
'If not found then copy form the Original sheet ...
rOriginal.Copy
'... paste on the Find sheet and apply the Yellow interior color
With rTableFind.Rows(rTableFind.Rows.Count + 1)
.PasteSpecial
.Interior.Color = vbYellow
End With
'Extend the range so we add another record at the bottom again
Set rTableFind = shFind.Range(rTableFind, rTableFind.Rows(rTableFind.Rows.Count + 1))
End If
FindNextOriginal:
Next rOriginal
End Function