I am looking to concatenate cells in a column. the model begins with a model number without any . the options to that model begin with . I would like the marco to concatenate all the way until the beginning of the next model number (the next cell that does not begin with .) , then repeat process, I have provided a an example below. Any help would be greatly appreciated!
current State
abc
.bcr
.kjl
.plk
ghy
.ytr
.ihgew
.rth
.u
.lpn
trh
.pjkjh
.dsgyudd
.hg
.gfd
Future State
abc.bcr.kjl.plk
ghy.ytr.ihgew.rth.u.lp
trh.pjkjh.dsgyudd.hg.gfd
Try this:
Option Explicit
Sub ConditionalConcatenate()
'col A contain the texts and col B in corresponding row hold concatenated result
Dim strDone As String
Dim rngg As Range, lastcolA As Range, rngused As Range
Dim counted As Integer, i As Integer, j As Integer
Range("B:B").ClearContents
strDone = ""
Set rngg = ActiveSheet.Range("A:A")
Set lastcolA = rngg.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
Set rngused = Range("A1:A" & lastcolA.Row)
counted = rngused.Rows.Count
For i = 1 To counted
If Left(rngused(i), 1) <> "." Then
strDone = strDone & rngused(i)
For j = 1 To counted
If Left(rngused(i).Offset(j, 0), 1) = "." Then
strDone = strDone & rngused(i).Offset(j, 0)
ElseIf Left(rngused(i).Offset(j, 0), 1) <> "." Then
Range("B" & i).Value = strDone
strDone = ""
Exit For
End If
Next
End If
Next
Set rngg = Nothing
Set lastcolA = Nothing
Set rngused = Nothing
End Sub
Related
I am trying to make a code to loop the column b and then fill column c based on if its empty or not but its not working when I set the data into the middel of the excel sheet
Sub FillCellFromAbove()
Dim x As Integer
Dim y As Integer
y = Application.WorksheetFunction.Count(Range("B:B")) + 1
For x = 1 To y
Range("C3:C7" & x).Select
If Range("B" & x) = "" Then
ActiveCell.Value = "Yes"
ElseIf Range("B" & x) <> "" Then
ActiveCell.Value = "NO"
End If
Next x
End Sub
Range("C3:C7" & x).Select is selecting a range starting at C3 and ending at C71 for the first loop and C72 for the second. Doubt that is what you want.
Also COUNT only counts the cells with numbers not the cells in a range from the first cell with a value to the last. So in this case you would return 4 and do 4 loops.
Use:
Sub FillCellFromAbove()
Dim x As Long
Dim y As Long
With ActiveSheet 'Better to set actual sheet
y = .Cells(.Rows.Count,2).End(XlUp).Row
For x = 3 To y
If .Cells(x,2) <> "" Then
.Cells(x,3) = "Yes"
Else
.Cells(x,3) = "No"
End If
Next x
End With
End Sub
Flag Empty and Non-Empty Using Evaluate
Sub FlagEmptyNonEmpty()
Const SourceColumn As String = "B"
Const DestinationColumn As String = "C"
Const YesFlag As String = "Yes"
Const NoFlag As String = "No"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
With Intersect(ws.UsedRange, ws.Columns(SourceColumn))
.EntireRow.Columns(DestinationColumn).Value _
= ws.Evaluate("IF(ISBLANK(" & .Address(0, 0) & "),""" _
& YesFlag & """,""" & NoFlag & """)")
End With
End Sub
I have been trying to work on this sumif code for a while but keep getting an error (Run Time Error 1004 'Unable to get the SumIfs property of the Worksheet Function class). anyone have any ideas as to why?
I am trying to match an ID that I have on column B (basically a table) and match it with all the IDs present on column F. If there are matches, then i want to take all the quantities/values the ID has and sum them. Then place the sum on column C next to the corresponding ID
lastrowB = cnCS.Range("B" & Rows.Count).End(xlUp).Row
Set rngtotalvalue = cnCS.Range("B50:B" & lastrowB)
lastrow = cnCS.Range("F" & Rows.Count).End(xlUp).Row
Set datarange = cnCS.Range("F3:T" & lastrow)
Dim rgColumnC As Range, n As Long
For Each rgColumnC In rngtotal.Rows
Set columnB = cnCS.Range("S3:S" & lastrow)
totalvalue = Application.WorksheetFunction.SumIf(datarange, rngtotalvalue, columnB)
rgColumnC.Cells(1, 2) = totalvalue
Next rgColumnC
Dim rgWeightRow As Range
For Each rgWeightRow In datarange.Rows
sAccountNumber = rgWeightRow.Cells(1, 1)
sEuro = rgWeightRow.Cells(1, 14)
sTotalValue = Application.WorksheetFunction.VLookup(sAccountNumber, rngtotal, 2, False)
sWeight = (sEuro / totalvalue)
rgWeightRow.Cells(1, 15).Value = sWeight
Next rgWeightRow
Here's one approach using a dictionary to track the sums:
Sub SumUp()
Dim dict As Object, data As Range, rw As Range, k, v
Set dict = CreateObject("scripting.dictionary")
Set data = Sheets("data").Range("A2:X7000") 'for example
For Each rw In data.Rows
k = rw.Columns("B").Value 'id's in ColB
v = rw.Columns("X").Value 'values in ColX
If Len(k) > 0 And IsNumeric(v) Then
dict(k) = dict(k) + v
End If
Next rw
'output the sums
With Sheets("Summary").Range("A2")
.Resize(dict.Count).Value = Application.Transpose(dict.keys)
.Offset(0, 1).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
End Sub
EDIT: seems like this would be closer to what you want
Sub Tester()
Dim ws As Worksheet, addrB As String, addrF As String, addrS As String, frm As String
Set ws = ActiveSheet
addrB = ws.Range("B50:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Address
addrF = ws.Range("F3:F" & ws.Cells(Rows.Count, "F").End(xlUp).Row).Address
addrS = ws.Range("S3:S" & ws.Cells(Rows.Count, "F").End(xlUp).Row).Address
With ws.Range(addrB).Offset(0, 1)
.FormulaArray = "=SUMIF(" & addrF & "," & addrB & "," & addrS & ")"
.Value = .Value
End With
End Sub
I read many post on this forum regarding my problem, but cant find solutions.
I have a table with different number of cells, with duplicate value.
I would like to count duplicates and show in another columns.
Source table where I mark a few cell:
I would like to receive such output
A have a part of code, but whatever I select, it counts the last cell
Dim rng, rngTarget, rngTargetName As Range
Set rngTarget = Range("D7")
Set items = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If Not items.exists(rng.Value) Then
items.Add rng.Value, 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
Else
items(rng.Value) = items(rng.Value) + 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
End If
Next
What i missing?
First enter this in a Standard Module:
Public Function unikue(rng As Range)
Dim arr, c As Collection, r As Range
Dim nCall As Long, nColl As Long
Dim i As Long
Set c = New Collection
nCall = Application.Caller.Count
On Error Resume Next
For Each r In rng
If r.Value <> "" Then
c.Add r.Text, CStr(r.Text)
End If
Next r
On Error GoTo 0
nColl = c.Count
If nCall > nColl Then
ReDim arr(1 To nCall, 1 To 1)
For i = 1 To nCall
arr(i, 1) = ""
Next i
Else
ReDim arr(1 To nColl, 1 To 1)
End If
For i = 1 To nColl
arr(i, 1) = c.Item(i)
Next i
unikue = arr
End Function
The above UDF() will return a list of the unique, non-blank, items in a block of cells.
Then in a set of cells in column, say F starting at F5 , array-enter:
=unikue(A1:D3)
In G5 enter:
=COUNTIF($A$1:$D$3,F5)
and copy downward:
With Excel 365, there is a no-VBA solution.
Thanks Gary's for help, but ...
i completed my version of code and now works as expected - i can select few cell and count duplicates.
My working code:
Dim rng As Range
Dim var As Variant
Dim i As Integer
i = 0
Set D = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If rng <> "" Then
If D.exists(rng.Value) Then
D(rng.Value) = D(rng.Value) + 1
Else
D.Add rng.Value, 1
End If
End If
Next
For Each var In D.Keys
Range("C" & (i + 18)) = var
Range("E" & (i + 18)) = D(var)
i = i + 1
Next
Set D = Nothing
I have 3 sheets that need to check if they have same value. All value on column B6 until last row should be same in Sheets MM, PP and CO. If there's difference value, the different value should be on highlight (the color is red).
But, my syntax didn't run. The syntax just can read if there's an empty column in range. This is my syntax.. Not including highlight. First, i tried to place the difference value to the other sheets. But, failed. Thank you.
Sub MatchValue()
Dim x As Integer
Dim y As Integer
Dim z As Integer
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
x = ActiveWorkbook.Worksheets("MM").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
y = ActiveWorkbook.Worksheets("PP").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
z = ActiveWorkbook.Worksheets("CO").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
If x <> y Then
MsgBox "MM <> PP", vbCritical, "Error Report"
End If
If y <> z Then
MsgBox "PP <> CO", vbCritical, "Error Report"
End If
If z <> x Then
MsgBox "CO <> MM", vbCritical, "Error Report"
End If
SheetMM = "MM"
DataColumnMM = "B6"
SheetPP = "PP"
DataColumnPP = "B6"
SheetCO = "CO"
DataColumnCO = "B6"
SheetUnmatched = "Data Unmatched"
DataColumnUnmatched = "A1"
DataRowMM = Range(DataColumnMM).Row
DataColMM = Range(DataColumnMM).Column
DataRowPP = Range(DataColumnPP).Row
DataColPP = Range(DataColumnPP).Column
DataRowCo = Range(DataColumnCO).Row
DataColCo = Range(DataColumnCO).Column
DataRowUnmatched = Range(DataColumnUnmatched).Row
DataColUnmatched = Range(DataColumnUnmatched).Column
LastDataMM = Sheets(SheetMM).Cells(Rows.Count, DataColMM).End(xlUp).Row
LastDataPP = Sheets(SheetPP).Cells(Rows.Count, DataColPP).End(xlUp).Row
LastDataCO = Sheets(SheetCO).Cells(Rows.Count, DataColCo).End(xlUp).Row
LastDataUnmathced = Sheets(SheetUnmatched).Cells(Rows.Count, DataColUnmatched).End(xlUp).Row
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataPP, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowPP To LastDataRowPP
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
End Sub
Based on the information you've provided, you want to:
Check three tables across three sheets in the ActiveWorkbook
Check to see if the same number of constants exists in the table ranges
Highlight cells red where the values between the three sheets aren't the same
I've simplified the code in order to achieve these targets
Sub MatchValue()
Dim Range1 As Range, Range2 As Range, Range3 As Range
With ActiveWorkbook
With .Sheets("MM") 'First Sheet Name
Set Range1 = .Range("B6") 'Address of first row on First Sheet
Set Range1 = .Range(Range1, .Cells(.Rows.Count, Range1.Column).End(xlUp))
End With
With .Sheets("PP") 'Second Sheet Name
Set Range2 = .Range("B6") 'Address of first row on second Sheet
Set Range2 = .Range(Range2, .Cells(.Rows.Count, Range2.Column).End(xlUp))
End With
With .Sheets("CO") 'Third Sheet Name
Set Range3 = .Range("B6") 'Address of first row on third Sheet
Set Range3 = .Range(Range3, .Cells(.Rows.Count, Range3.Column).End(xlUp))
End With
End With
'Delete this part if you don't want to remove the existing fill (might be handy)
Range1.Interior.Pattern = xlNone
Range2.Interior.Pattern = xlNone
Range3.Interior.Pattern = xlNone
'Checks to see if the same number of constants exist within the test ranges
If Range1.SpecialCells(xlCellTypeConstants).Count <> _
Range2.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
ElseIf Range2.SpecialCells(xlCellTypeConstants).Count <> _
Range3.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
End If
Dim Temp1 As Variant, Temp2 As Variant, Temp3 As Variant, x As Long
'Checks to see if all the values entered are the same, if not, fills them red
Temp1 = Range1.Value
Temp2 = Range2.Value
Temp3 = Range3.Value
For x = 1 To UBound(Temp1, 1)
If Temp1(x, 1) <> Temp2(x, 1) Or _
Temp2(x, 1) <> Temp3(x, 1) Then
Range1.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range2.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range3.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
End If
Next x
End Sub
In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.
You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub