In an Excel sheet, one column is with date and we need to validate all the values in that column and check whether they are in MMDDYY format or not. If not, we need to highlight that specific cell with a colour.
Sub effectivedate()
Dim a As Integer
With ThisWorkbook.Sheets("sheet2")
For a = 2 To .Range("e" & Rows.Count).End(xlUp).Row
k = .Range("e" & a)
p = Len(k)
If Application.WorksheetFunction.Count(k) = 1 And p <> 6 Then
.Range("e" & a).Interior.ColorIndex = 6
End If
Next
End With
End Sub
Please, test the next code. It creates the appropriate date from existing Date or String and color the cells keeping text with a length different from 6:
Sub MakeDateMMDDYY()
Dim ws As Worksheet, a As Long, lastR As Long
Dim txtD As String, arr, arrFin, rngCol As Range, colLett As String
colLett = "F" 'the column letter where to be returned the processing result
'if the code returns what you need, you can replade F with E
Set ws = ThisWorkbook.Sheets("sheet2")
lastR = ws.Range("E" & rows.count).End(xlUp).row
arr = ws.Range("E2:E" & lastR).value 'place the range in an array for faster iteration
ReDim arrFin(1 To UBound(arr), 1 To 1) 'redim the array to receive the processing result
For a = 1 To UBound(arr)
txtD = ws.Range("E" & a + 1).text 'place the cell text in a string variable
If Len(txtD) = 6 Then
'create a date from the string and place it in the final array:
arrFin(a, 1) = DateSerial(CLng(Right(txtD, 2)) + 2000, CLng(left(txtD, 2)), CLng(Mid(txtD, 3, 2))): 'Stop
Else
arrFin(a, 1) = txtD 'place the string in the final array
If rngCol Is Nothing Then
Set rngCol = ws.Range(colLett & a + 1) 'first time create the range to be colored
Else
Set rngCol = Union(rngCol, ws.Range(colLett & a + 1)) 'then, use a Union for the next cells to be colored
End If
End If
Next
With ws.Range(colLett & 2).Resize(UBound(arrFin), 1) 'format the range and drop the final array result
.NumberFormat = "MMDDYY"
.value = arrFin
End With
If Not rngCol Is Nothing Then rngCol.Interior.ColorIndex = 6 'color the range keeping the cells to be colored
End Sub
I want to compare two ID lists with different lengths. The first list is longer and has Values, while the second has no Values.
When the ID's match, it should paste the Value in the first list to the appropriate place beside list 2.
Sub compareList()
Dim v1, v2, v4, v3()
Dim i As Long
Dim j As Long
v1 = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
v2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
v4 = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
ReDim v3(1 To 4)
For i = LBound(v1) To UBound(v1)
If IsError(Application.Match(v1(i, 1), v4, 0)) Then
j = j + 1
Else
v3(j) = v2(i, 1)
End If
Next i
Range("E2").Resize(i) = Application.Transpose(v3)
End Sub
It gives me an out of index error, or pastes the value in the order it reads it (without paying attention to the match).
If you do not like Vlookup and need some VBA code, please test the next code:
Sub compareList()
Dim sh As Worksheet, lastR As Long, lastR2 As Long, i As Long, j As Long, arr, arrFin
Set sh = ActiveSheet
lastR = sh.Range("A" & rows.count).End(xlUp).row
lastR2 = sh.Range("D" & rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).Value
arrFin = sh.Range("D2:E" & lastR2).Value
For i = 1 To UBound(arrFin)
For j = 1 To UBound(arr)
If arrFin(i, 1) = arr(j, 1) Then arrFin(i, 2) = arr(j, 2): Exit For
Next j
Next i
sh.Range("D2:E" & lastR2).Value = arrFin
End Sub
Just continuing on and referring to #FaneDuru stating
If you don't like Vlookup and need some VBA code:
1) Example code using Match()
Sub compareListTM()
'define arrays using help function getRange()
Dim arr: arr = getRange(Sheet1.Range("A:A")).Value
Dim data: data = getRange(Sheet1.Range("B:B")).Value
Dim arrFin: arrFin = getRange(Sheet1.Range("D:D")).Value
Dim ret: ret = Application.Match(arrFin, arr, 0) ' Match() items all at once :-)
Dim i As Long
For i = 1 To UBound(ret)
If Not IsError(ret(i, 1)) Then
ret(i, 1) = data(ret(i, 1), 1)
Else
ret(i, 1) = vbNullString
End If
Next i
Sheet1.Range("E2").Resize(UBound(ret), 1).Value = ret
End Sub
If, however you could give VLookUp a try:
2) Example code using worksheetfunction
Sub compareList2()
Dim results
results = WorksheetFunction.VLookup( _
getRange(Sheet1.Range("D:D")), _
getRange(Sheet1.Range("A:B")), _
2, False)
'write results
Sheet1.Range("E2").Resize(UBound(results), 1).Value = results
End Sub
Help function getRange() used in both examples
A way to avoid repeated lastRow, Range definitions in main code.
I don't pretend this function to be perfect in any way, it just meets the necessary requirements for above procedures kept as short as possible.
Function getRange(ColRange As Range, _
Optional ByVal SearchColumn As Variant = 1, _
Optional ByVal StartRow As Long = 2) As Range
'Author : https://stackoverflow.com/users/6460297/t-m
'Purpose: calculate lastrow of a given search column (default: 1st column of ColRange) and
' return ColRange resized to calculated lastrow (considering optional StartRow argument)
'Par. 1 : assumes that ColRange is passed as ENTIRE COLUMN(S) range object, e.g. Range("X:Y")
'Par. 2 : a) a numeric SearchColumn argument refers to the ColRange's column index
' (even outside ColRange, can be negative or higher than columns count in ColRange!)
' b) a literal SearchColumn argument refers to the worksheet column as indicated (e.g. "B")
'Example: getRange(Sheet1.Range("X:Y")) ... calculates lastrow of 1st column in colRange (i.e. in X)
' getRange(Sheet1.Range("X:Y"), "B") ... calculates lastrow of column B in worksheet
'~~~~~~
'1) get columns in ColRange
Dim StartColumn As Long: StartColumn = ColRange.Columns(1).Column
Dim LastColumn As Long: LastColumn = ColRange.Columns(ColRange.Columns.Count).Column
With ColRange.Parent ' i.e. the worksheet
'2) change numeric search column number to letter(s)
If IsNumeric(SearchColumn) Then
If SearchColumn + StartColumn - 1 < 1 Then ' cols left of StartColumn must be at least "A"
SearchColumn = "A"
Else ' get literal column name, e.g. column "D"
SearchColumn = Split((.Columns(SearchColumn + StartColumn - 1).Address(, 0)), ":")(0)
End If
End If
'3) get last row of SearchColumn
Dim lastRow As Long: lastRow = .Range(SearchColumn & .Rows.Count).End(xlUp).Row
If lastRow < StartRow Then lastRow = StartRow ' avoid findings lower than start row
'4) return data range as function result
Set getRange = .Range(.Cells(StartRow, StartColumn), .Cells(lastRow, LastColumn))
End With
End Function
Im not sure exactly how to explain this in a google search so im not sure if anyone else has asked this.
I have a vba function that takes a range and turns it into a string of comma separated values.
It works like a charm.
Now i want it to only output the first 41 entries, switch down a row and output the next 41 entries in the range.
I cant quite wrap my head around it, it feels like a simple loop but i cant quite get there.
I found the csvrange macro online somewhere :)
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry As Variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
Input range would look like this
Desired output would look like this, one string located in column B each group of 41 values separated on a row, offsetting 1 down each time the function hits the next nr 42.
Something like this:
Option Explicit
Public Sub test()
Debug.Print csvRange(Selection, 41)
End Sub
Public Function csvRange(ByVal myRange As Range, ByVal Columns As Long) As String
Dim csvRangeOutput
Dim iCol As Long
Dim Entry As Variant
For Each Entry In myRange
If Not IsEmpty(Entry.Value) Then
iCol = iCol + 1
csvRangeOutput = csvRangeOutput & Entry.Value
If iCol = Columns Then
csvRangeOutput = csvRangeOutput & vbCrLf
iCol = 0
Else
csvRangeOutput = csvRangeOutput & ","
End If
End If
Next
csvRange = Left$(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
will turn this data
into comma separated values with 41 columns
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41
42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82
83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123
124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140
Alternative
Public Sub Convert()
Const ColCount As Long = 41
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow Step ColCount
ws.Cells(iRow \ ColCount + 1, "B").Value = "'" & Join((WorksheetFunction.Transpose(ws.Range("A" & iRow).Resize(RowSize:=IIf(iRow + ColCount - 1 > LastRow, WorksheetFunction.Max(LastRow Mod ColCount, 2), ColCount)).Value)), ",")
Next iRow
End Sub
Please, test the next code. It will do what (I understood) you need, for as many records you have in column A:A. It should be fast, using arrays and working in memory. The single iteration is for the necessary number of range slices:
Private Sub testStringCSVArray()
Dim sh As Worksheet, arr, nrSlices As Long, LastRow As Long, rngF As Range
Dim rngStart As Range, i As Long, k As Long, h As Long, arrFin
Set sh = ActiveSheet
LastRow = sh.Range("A1").End(xlDown).row
LastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of A:A
arr = sh.Range("A1:A" & LastRow).Value 'put the range in an array
nrSlices = UBound(arr) \ 41 'determine the number of necessary slices
ReDim arrFin(nrSlices + 1)
Set rngStart = sh.Range("B" & UBound(arr) + 2) 'set the cell where the result to be returned
For i = 1 To nrSlices + 1
arrFin(h) = CStr(Join(Application.Transpose(Application.Index(arr, _
Evaluate("row(" & k + 1 & ":" & IIf(i <= nrSlices, 41 + k, UBound(arr)) & ")"), 1)), ","))
k = k + 41: h = h + 1
Next i
'Format the range where the processed data will be returned and drop the processed data array:
With rngStart.Resize(h, 1)
.NumberFormat = "#"
.Value = WorksheetFunction.Transpose(arrFin)
End With
End Sub
In order to avoid deleting of the already processed data, in case of whishing to run the code twice or more times, the processed data will be returned in column B:B, two rows down from the last cell in column A:A. If after testing, the code proves to be reliable and no need to run it one more time, Set rngStart = sh.Range("B" & UBound(arr) + 2) can be modified in Set rngStart = sh.Range("A" & UBound(arr) + 2).
Without preliminary formatting as text the area where the data will be dropped, Excel changes the NumberFormat in "scientific", when the comma delimited string contains (only) numbers of three digits each. It looks to consider the comma as a thousands separator...
I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub
I have a similar task as in there:
Copy value N times in Excel
But mine is a bit more complex.
So, I have this kind of sheet:
A B
dog-1.txt 3
cat-1.txt 2
rat-1.txt 4
cow-1.txt 1
The final result needs to be the following:
A
dog-1.txt
dog-2.txt
dog-3.txt
cat-1.txt
cat-2.txt
rat-1.txt
rat-2.txt
rat-3.txt
rat-4.txt
cow-1.txt
As you see it doesn't only multiply the cell content X times taken from column B, but it also increases the number in file name the same number of times with 1 step increase.
How could I achieve that?
Try the following (tried and tested):
Sub Extend()
Dim Rng As Range, Cell As Range
Dim WS As Worksheet, NewCell As Range
Dim Dict As Object, NewStr As String
Set WS = ThisWorkbook.Sheets("Sheet1") 'Modify as necessary.
Set Rng = WS.Range("A1:A5") 'Modify as necessary.
Set Dict = CreateObject("Scripting.Dictionary")
For Each Cell In Rng
If Not Dict.Exists(Cell.Value) Then
Dict.Add Cell.Value, Cell.Offset(0, 1).Value
End If
Next Cell
Set NewCell = WS.Range("C1") 'Modify as necessary.
For Each Key In Dict
For Iter = 1 To CLng(Dict(Key))
NewStr = "-" & Iter & ".txt"
NewStr = Mid(Key, 1, InStrRev(Key, "-") - 1) & NewStr
NewCell.Value = NewStr
Set NewCell = NewCell.Offset(1, 0)
Next Iter
Next Key
End Sub
Screenshot (after running):
The logic here is to get each name from the first column, store it as a dictionary key, then get the value beside it and store that that as the key-value. We then iterate inside each of the dictionary's keys, where we use the key-value as the upperbound of the iteration. During each iteration, we modify the string to change its number to the "current digit" of the iteration.
We choose C1 as the initial target cell. Every iteration, we offset it one (1) row below to accommodate the new/next iteration.
Let us know if this helps.
Tested , is this what u wanted :) ? (Working fine in my system)
Sub teststs()
Dim erange As Range
Dim lrow As Integer
Dim cnt As Integer
Dim rnt As Integer
Dim str As String
Dim lrow2 As Integer
With ActiveSheet
lrow = .Range("A" & Rows.Count).End(xlUp).Row ' finding the last row
For Each erange In .Range("A1:A" & lrow) ' loop though each each cell in the A column
cnt = erange.Offset(0, 1).Value
rnt = Mid(erange.Value, InStr(erange.Value, "-") + 1, 1)
For i = 1 To cnt 'Looping to cnt times
With Sheets("Sheet2")
lrow2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
str = Replace(erange.Value, rnt, i, InStr(erange.Value, "-") + 1)
.Range("A" & lrow2).Value = Left(erange.Value, InStr(erange.Value, "-")) & str
End With
Next i
Next erange
End With
End Sub