I'm stuck trying to work out the vba code to convert a column of excel date\time values into a string value of just the time in 24 hour format (HH:MM).
I can read the property when I loop through the collection, but i'm unable to set the formatting:
Dim dt As Date
Dim rng As Range: Set rng = Application.Range("sheet2!E2:E100")
DIm i As Integer
For i = 1 To rng.Rows.Count
dt = rng.Cells(RowIndex:=i, ColumnIndex:="E").Value
rng.Cells(RowIndex:=i, ColumnIndex:="E").NumberFormat = "#" '// <-- Exception Here
rng.Cells(RowIndex:=i, ColumnIndex:="E").Value = Format(dt, "HH:MM")
Next
Why is it throwing an exception?
I'm trying to run this on entire column E, but E1 is a header, and the size of E is unknown, how can i account for this?
I don't know why you're getting an exception but the following code works for me:
Sub StringTime()
Dim rng As Range
Dim lRow As Long
Dim strTime As String
'find last row
lRow = Range("E1").CurrentRegion.Rows.Count
Set rng = Range("E2:E" & lRow)
For i = 1 To rng.Rows.Count
strTime = Hour(rng.Cells(i).Value) & ":" & Minute(rng.Cells(i).Value)
rng.Cells(i).NumberFormat = "#"
rng.Cells(i).Value = strTime
Next i
End Sub
Note that I'm finding the last row in column E before setting the range. This will fix your variable size problem.
Related
First question ever here, I am the newbiest newbie..
So.. what I am trying to get is:
to find if in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2. if there are, then copy the value from sheet2 column A row x to sheet2 column P row y.
rows x and y are where the identical values are on each sheet.
this is my code:
Sub ccopiazanrfact()
Dim camion As Worksheet
Dim facturi As Worksheet
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Dim nrcomanda As String
Dim nrfactura As String
For a = 2 To facturi.Range("F" & Rows.Count).End(xlUp).Row
nrcomanda = facturi.Range("F" & a).Value
For b = 4 To camion.Range("E" & Rows.Count).End(xlUp).Row
If camion.Range("E" & b).Value = facturi.Range("F" & a).Value Then
camion.Range("P" & b) = facturi.Range("A" & a).Value
Exit For
End If
Next b
Next a
End Sub
I would recommend using arrays to achieve what you want. Nested looping over ranges can make it very slow. Is this what you are trying? (UNTESTED). As I have not tested it, I would recommend making a backup of your data before you test this code.
I have commented the code. But if you still have a question or find an error/bug in the below code then simply ask.
Option Explicit
Sub ccopiazanrfact()
Dim Camion As Worksheet
Dim Facturi As Worksheet
Set Camion = ThisWorkbook.Sheets("B816RUS")
Set Facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
'~~> Declare 2 arrays
Dim ArCamion As Variant
Dim ArFacturi As Variant
Dim LRow As Long
'~~> Find last row in Col E of Sheets("B816RUS")
LRow = Camion.Range("E" & Camion.Rows.Count).End(xlUp).Row
'~~> Store Values from E4:P last row in the array. We have taken E:P
'~~> because we are replacing the value in P if match found
ArCamion = Camion.Range("E4:P" & LRow).Value
'~~> Find last row in Col E of Sheets("EVIDENTA FACTURI")
LRow = ArFacturi.Range("F" & ArFacturi.Rows.Count).End(xlUp).Row
'~~> Store Values from A2:F last row in the array. We have taken A:F
'~~> because we are replacing the value in P with A
ArFacturi = Facturi.Range("A2:F" & LRow).Value
Dim i As Long, j As Long
For i = 2 To UBound(ArFacturi)
For j = 4 To UBound(ArCamion)
'~~> Checking if camion.Range("E" & j) = facturi.Range("F" & i)
If ArCamion(j, 1) = ArFacturi(i, 6) Then
'~~> Replacing camion.Range("P" & j) with facturi.Range("A" & i)
ArCamion(j, 12) = ArFacturi(i, 1)
Exit For
End If
Next j
Next i
'~~> Write the array back to the worksheet in one go
Camion.Range("E4:P" & LRow).Resize(UBound(ArCamion), 12).Value = ArCamion
End Sub
in the end, I came up with this and works instantly, get’s all the data filled within a blink of an eye. When I tried it first time I thought i forgot to clear the data before running the code:
Sub FindMatchingValues()
'Declare variables for the worksheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'Set the variables to refer to the worksheets
Set ws1 = Worksheets("B816RUS")
Set ws2 = Worksheets("EVIDENTA FACTURI")
'Declare variables for the ranges to compare
Dim rng1 As Range
Dim rng2 As Range
'Set the ranges to the columns to compare
Set rng1 = ws1.Range("E1", ws1.Range("E" & Rows.Count).End(xlUp))
Set rng2 = ws2.Range("F1", ws2.Range("F" & Rows.Count).End(xlUp))
'Loop through each cell in the first range
For Each cell1 In rng1
'Use the Match function to find the matching value in the second range
Dim match As Variant
match = Application.match(cell1.Value, rng2, 0)
'If a match was found, copy the value from column A in the second worksheet to column P in the first worksheet
If Not IsError(match) Then
ws1.Range("P" & cell1.Row).Value = ws2.Range("A" & match).Value
End If
Next cell1
End Sub
Please, test the next code. It should be very fast, using arrays and Find function:
Sub ccopiazaNrfact()
Dim camion As Worksheet, facturi As Worksheet, cellMatch As Range, rngE As Range
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Set rngE = camion.Range("E4:E" & camion.Range("E" & camion.rows.count).End(xlUp).row)
Dim a As Long, arrFact, arrP, nrComanda As String
arrP = camion.Range("P1:P" & camion.Range("E" & rows.count).End(xlUp).row).Value
arrFact = facturi.Range("A2:F" & facturi.Range("F" & rows.count).End(xlUp).row).Value
Debug.Print UBound(arrP): Stop
For a = 1 To UBound(arrFact)
nrComanda = arrFact(a, 6)
Set cellMatch = rngE.Find(What:=nrComanda, After:=rngE.cells(1, 1), LookIn:=xlValues, lookAt:=xlWhole)
If Not cellMatch Is Nothing Then
arrP(cellMatch.row, 1) = arrFact(a, 1)
End If
Next a
camion.Range("P1").Resize(UBound(arrP), 1).Value = arrP
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it...
A VBA Lookup: Using Arrays and a Dictionary
Option Explicit
Sub CopiazaNrFact()
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the Source Compare and Value ranges to arrays.
' f - Facturi (Source), c - Compare, v - Value
Dim frg As Range, fcData() As Variant, fvData() As Variant, frCont As Long
With wb.Sheets("EVIDENTA FACTURI")
' Compare
Set frg = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
frCont = frg.Rows.Count
fcData = frg.Value ' write to array
' Value
Set frg = frg.EntireRow.Columns("A")
fvData = frg.Value ' write to array
End With
' Write the unique values from the Source Compare array to the 'keys',
' and their associated values from the Source Values array to the 'items'
' of a dictionary.
Dim fDict As Object: Set fDict = CreateObject("Scripting.Dictionary")
fDict.CompareMode = vbTextCompare
Dim fr As Long, NrFacturi As String
For fr = 1 To frCont
NrFacturi = CStr(fcData(fr, 1))
If Len(NrFacturi) > 0 Then ' exclude blanks
fDict(NrFacturi) = fvData(fr, 1)
End If
Next fr
' Write the values from the Destination Compare range to an array
' and define the resulting same-sized Destination Value array.
' c - Camion (Destination), c - Compare, v - Value
Dim crg As Range, ccData() As Variant, cvData() As Variant, crCont As Long
With wb.Sheets("B816RUS")
' Compare
Set crg = .Range("E4", .Cells(.Rows.Count, "E").End(xlUp))
crCont = crg.Rows.Count
ccData = crg.Value ' write to array
' Value
Set crg = crg.EntireRow.Columns("P")
ReDim cvData(1 To crCont, 1 To 1) ' define
End With
' For each value in the Destination Compare array, attempt to find
' a match in the 'keys' of the dictionary, and write the associated 'item'
' to the same row of the Destination Value array.
Dim cr As Long, NrCamion As String
For cr = 1 To crCont
NrCamion = CStr(ccData(cr, 1))
If fDict.Exists(NrCamion) Then cvData(cr, 1) = fDict(NrCamion)
Next cr
' Write the values from the Destination Value array
' to the Destination Value range.
crg.Value = cvData
End Sub
I have a task to drag formulas in several columns based on length of one specific column (which length can vary).
I managed to do it, but had to create new line of code for each range.
Sample of my Variant 1:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
Set tr = Range("A14:G" & LastRowEPS)
Range("A14:G14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
Set tr = Range("I14:K" & LastRowEPS)
Range("I14:K14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
End Sub
I want to optimize my code and include several variable ranges in one line of code.
Here is my Variant 2:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
LastRowEPS = Sheet1.Cells(14, 12).End(xlDown).Row
Set tr = Range("A14:G" & LastRowEPS & ", I14:K" & LastRowEPS & ", M14:N" & LastRowEPS & ", P14:P" & LastRowEPS)
Range("A14:G14,I14:K14,M14:N14,P14:P14").Select
Selection.AutoFill Destination:=tr, Type:=xlFillDefault
End Sub
The selection process works, and tr.Range is defined properly, but VBA autofill shows Error:
Run-time error '1004': AutoFill method of Range class failed
Is it possible to include several variable ranges as destination of autofill or any other way to optimize my code?
Actually i found out a solution, which i was lookin for. Maybe for someone it will be helpful. .AutoFill is bad with multiple ranges, that's why simple use of .FillDown is an answer here:
Sub DragRows()
Dim LastRowEPS As Integer
Dim tr As Range
LastRowEPS = Sheet1.Cells(14, 12).End(xlDown).Row
Set tr = Sheet1.Range("A14:G" & LastRowEPS & ", I14:K" & LastRowEPS & ", M14:N" & LastRowEPS & ", P14:P" & LastRowEPS)
tr.FillDown
End Sub
AutoFill, Formula, FillDown
The following shows two different approaches.
OP already revealed the superior solution, which is covered in the second procedure.
Three Solutions (Inferior: Applied to Four Ranges)
Sub dragRows()
' Define constants.
Const FirstRow As Long = 14
Const LastRowCol As Long = 12
Dim Cols As Variant
Cols = Array("A:G", "I:K", "M:N", "P")
' In worksheet...
With Sheet1
' Determine Rows Count.
Dim RowsCount As Long
RowsCount = .Cells(FirstRow, LastRowCol).End(xlDown).Row - FirstRow + 1
' Declare variables
Dim rng As Range
Dim n As Long
' Define and fill each range.
For n = LBound(Cols) To UBound(Cols)
Set rng = .Columns(Cols(n)).Rows(FirstRow)
' Choose one of the following solutions
rng.AutoFill Destination:=rng.Resize(RowsCount), Type:=xlFillDefault
'rng.Resize(RowsCount).Formula = rng.Formula
'rng.Resize(RowsCount).FillDown
Next n
End With
End Sub
FillDown Solution (Superior: Applied to One Range)
Sub dragRowsFillDown()
' Define constants.
Const FirstRow As Long = 14
Const LastRowCol As Long = 12
Dim Cols As Variant
Cols = Array("A:G", "I:K", "M:N", "P")
' In worksheet...
With Sheet1
' Determine Rows Count.
Dim RowsCount As Long
RowsCount = .Cells(FirstRow, LastRowCol).End(xlDown).Row - FirstRow + 1
' Declare variables
Dim rng As Range
Dim n As Long
' Define (non-contiguous) range.
For n = LBound(Cols) To UBound(Cols)
If Not rng Is Nothing Then
Set rng = Union(rng, .Columns(Cols(n)).Rows(FirstRow) _
.Resize(RowsCount))
Else
Set rng = .Columns(Cols(n)).Rows(FirstRow).Resize(RowsCount)
End If
Next n
End With
rng.FillDown
End Sub
I want a CountIf Formula in which JV_Rng (workbook 1 range) is the range and 9th column (and r row) of GL_Sheet (workbook 2) is the criteria. Upon running the code I receive error 1004 (application or object defined error)
The error is possibly due to my inability to include the JV_Rng in the Count If Formula. The whole code is as follows
'Filtering Range
Dim GL_Code As Single, GL_Rng As range, GL_LR As Long
Dim GL_Sheet As Worksheet
Set GL_Sheet = Workbooks("Deodar GL activities.xlsx").Worksheets("Sheet1")
GL_LR = GL_Sheet.range("B" & Rows.Count).End(xlUp).Row
GL_Code = Application.InputBox(Prompt:="Enter GL code", Title:="Generate GL", Type:=1)
Set GL_Rng = GL_Sheet.range("A4:R" & GL_LR).CurrentRegion.Offset(3, 0)
GL_Rng.AutoFilter Field:=6, Criteria1:=GL_Code
'Shift Rng into new sheet
Dim Tgt_Book As Workbook
Set Tgt_Book = Workbooks.Add
Dim tgt As Worksheet: Set tgt = Tgt_Book.Worksheets.Add
......
'Shift JV of that Code
Dim r As Long, JV_Rng As range
Set JV_Rng = tgt.range("J6:R" & GL_LR).Offset(5, 0)
For r = 5 To GL_LR
GL_Sheet.range("S" & r).Formula = "=COUNTIF(tgt.Range(JV_rng),R[r]C[9])"
Next r
The code is working successfully except for this part
GL_Sheet.range("S" & r).Formula = "=COUNTIF(tgt.Range(JV_rng),R[r]C[9])"
Please, replace:
For r = 5 To GL_LR
GL_Sheet.range("S" & r).Formula = "=COUNTIF(tgt.Range(JV_rng),R[r]C[9])"
Next r
with
tgt.range("S5:S" & GL_LR).Formula = "=COUNTIF(" & JV_Rng.Address(external:=True) & ", I5)"
No iteration needed.
In above code line I tried to convert your R[r]C[9] in A1 notation. Would you like counting I:I column cells values in S:S column? Otherwise, your formula was not targeting the correct ranges...
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I am currently learning VBA and cant figure this one out. I'm trying to look at the max date in a range (W:AC) of each row and place the result in cell "BU" of the same row. I'm getting a 1004 error on the line defining which cell to place the result. Am I getting the error because I have defined the range as W:AC?
Sub Max_Date()
Dim MaxDate As Date
Dim CellRange As Range
Dim Source As Worksheet: Set Source = ActiveWorkbook.Sheets("Sheet1")
Dim row As Variant
row = Source.Rows.Count
Set CellRange = Source.Range("W:AC")
For Each row In CellRange
MaxDate = Application.WorksheetFunction.Max(CellRange)
Range("BU").Value = MaxDate
Next row
End Sub
As SJR mentioned you cannot paste a value in a row.
But also, you are looking at a max in the entire range, not only the row.
Use an integer (here i) to go through each row.
This should to the trick
Sub Max_Date()
Dim MaxDate As Date
Dim i As Double
Dim Source As Worksheet: Set Source = ActiveWorkbook.Sheets("Sheet1")
Dim row As Variant
row = Source.Rows.Count
For i = 1 To row
MaxDate = Application.WorksheetFunction.Max(Source.Range("W" & i & ":AC" & i))
Range("BU" & i).Value = MaxDate
Next
End Sub