Finding column based on header then formatting rows - excel

I am attempting to build a loop that searches through headers and finds a contained value, In this case, "Avg". If the value is found it will work down the column and apply a format based on a comparison to another column. I am trying to convert my cell variable in the For loop (Z) into a column address so I can use to control my ws.Cells() value in the next loop.
Any help is greatly appreciated, thanks!!!!
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim Z As Range
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
For Each Z In Range("I1:BM1").Cells
If InStr(1, Z.Value, "Avg") Then
For i = 2 To lastRow 'loop from row 2 to last
If ws.Cells(i, 8) - ws.Cells(i, Z) < 0 Then
ws.Cells(i, Z).Interior.ColorIndex = 4
End If
Next i
End If
Next Z
End Sub

It's not exactly clear to me what you want - but from the title it appears you want to get the column number based on the header text? If so, this will do that:
Private Function GetColumn(headerName As String) As Integer
Dim col As Integer
GetColumn = 0
For col = 1 To ActiveSheet.UsedRange.Columns.Count
If ActiveSheet.Cells(1, col).Value = headerName Then
GetColumn = col
Exit For
End If
Next col
End Function

Find Header and Format Cells
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a column range specified by its header,
' highlights the cells matching a condition.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub HighlightBelowAverages()
' Define constants.
Const PROC_TITLE As String = "Highlight Below-Averages"
Const COMPARE_COLUMN As String = "H"
Const AVG_SEARCH_COLUMNS As String = "I:BM"
Const AVG_COLUMN_HEADER As String = "Avg"
Const AVG_COLOR_INDEX As Long = 4 ' Bright Green
' Reference the Search range.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim srg As Range
' It is NOT assumed that the used range starts in row '1'.
Set srg = Intersect(ws.UsedRange, ws.Range(AVG_SEARCH_COLUMNS))
If srg Is Nothing Then
MsgBox "The Average search columns '" & AVG_SEARCH_COLUMNS _
& "' are not part of the used range.", vbCritical, PROC_TITLE
Exit Sub
End If
' Find the Average header cell.
Dim ahCell As Range
With srg
Set ahCell = .Find(AVG_COLUMN_HEADER, _
.Cells(.Rows.Count, .Columns.Count), xlFormulas, xlWhole, xlByRows)
End With
If ahCell Is Nothing Then
MsgBox "Header '" & AVG_COLUMN_HEADER & "' not found.", _
vbCritical, PROC_TITLE
Exit Sub
End If
' Reference the Average (single-column) range.
Dim afCell As Range: Set afCell = ahCell.Offset(1)
Dim alCell As Range
Set alCell = Intersect(srg.Rows(srg.Rows.Count), ws.Columns(ahCell.Column))
' It IS assumed that the data has one row of headers.
If afCell.Row > alCell.Row Then
MsgBox "No data found.", vbCritical, PROC_TITLE
Exit Sub
End If
Dim arg As Range: Set arg = ws.Range(afCell, alCell)
' Reference the Compare (single-column) range.
Dim crg As Range
' It is NOT assumed that the used range starts in column 'A'.
Set crg = Intersect(arg.EntireRow, ws.Columns(COMPARE_COLUMN))
' Highlight the cells.
Application.ScreenUpdating = False
arg.Interior.ColorIndex = xlNone
Dim aCell As Range, cCell As Range, r As Long
For Each aCell In arg.Cells
r = r + 1
Set cCell = crg.Cells(r)
If cCell.Value < aCell.Value Then ' Compare is less than Average
aCell.Interior.ColorIndex = AVG_COLOR_INDEX
End If
Next aCell
Application.ScreenUpdating = True
' Inform.
MsgBox "Below-averages highlighted.", vbInformation, PROC_TITLE
End Sub

Related

Trying to copy table range with criteria

Im trying to copy a table range with criteria, however I am not able to define the criteria to copy the desired lines, which consists of copying only the lines where the CC column has data skiping the entire row if CC is empty. I'll just copy ( copy to clipboard ), for paste I'll do it manually for other reasons
The lines will always be like this, never with a whole blank line between them like the second image
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For Each rng In .Range("B3:I3" & bottomA)
If WorksheetFunction.Sum(.Range("B" & rng.Row & ":I" & rng.Row)) > 0 Then
Range("B" & rng.Row & ":I" & rng.Row)).Copy
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Use Union to select a non-contiguous range.
Option Explicit
Sub CopyValues()
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, rngB As Range
Dim tbl As ListObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("CC2")
With ws.ListObjects("Tabela452")
For Each rngB In .ListColumns("CC").DataBodyRange
If Len(rngB) > 0 Then
If rng Is Nothing Then
Set rng = rngB.Resize(1, 8) ' B to I
Else
Set rng = Union(rng, rngB.Resize(1, 8))
End If
End If
Next
End With
If rng Is Nothing Then
MsgBox "Nothing selected", vbExclamation
Else
rng.Select
rng.Copy
MsgBox "range copied " & rng.Address, vbInformation
End If
End Sub
Please, test the next adapted code. It does not need any iteration:
Sub CopyValues()
Dim rngCopy As Range, tbl As ListObject
Dim srcWS As Worksheet: Set srcWS = Sheets("CC2")
Set tbl = srcWS.ListObjects(1) 'use here the table name, if more than 1
On Error Resume Next 'for the case of no any value in the table first column
Set rngCopy = tbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeConstants)
'or
'Set rngCopy = tbl.DataBodyRange.Columns(tbl.ListColumns("CC").Index).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngCopy Is Nothing Then 'for the case of no any values in table first column
Intersect(rngCopy.EntireRow, tbl.DataBodyRange).Copy
Else
MsgBox "No any value in column ""CC""..."
End If
End Sub
As I said in my comment, it works if the values in column "CC" are not result of formulas...
Copy Filtered Rows From Excel Table (ListObject)
The screenshot illustrates the benefits of using an Excel table:
The table can be anywhere on the worksheet.
You can easily reference a column by its name (header).
You can move the column anywhere in the table.
Sub CopyFilteredRows()
' Define constants.
Const WorksheetName As String = "CC2"
Const TableName As String = "Tabela452"
Const CriteriaColumnName As String = "CC"
Const Criteria As String = "<>" ' non-blanks ('blank' includes 'empty')
' Reference the objects ('wb', 'ws' , 'tbl', 'lc')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
Dim lc As ListColumn: Set lc = tbl.ListColumns(CriteriaColumnName)
' Reference the filtered rows ('rrg').
Dim rrg As Range
With tbl
If .ShowAutoFilter Then ' autofilter arrows are turned on
' Clear all filters.
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else ' autofilter arrows are turned off
.ShowAutoFilter = True ' turn on the autofilter arrows
End If
.Range.AutoFilter lc.Index, Criteria
' Attempt to reference the filtered rows ('rrg').
On Error Resume Next
' Reference the visible cells.
Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
' When columns are hidden, resize to entire rows of the table.
Set rrg = Intersect(.DataBodyRange, rrg.EntireRow)
On Error GoTo 0
' Clear the filter.
.AutoFilter.ShowAllData
End With
' Invalidate the filtered rows.
If rrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Copy.
rrg.Copy
End Sub
For the criteria when looking for empty values, you can always use LEN to check the number of characters in the cell.
If it is greater than 0 it means that something is in there, you can also set it to an exact amount of digits to be more precise.
Something like this should work:
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Dim currentRow As Long
Const ccColumn As Long = 2
Const startingRow As Long = 3
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For currentRow = startingRow To bottomA
If Len(.Cells(currentRow, ccColumn).Value) > 0 Then
.Range("B" & currentRow & ":I" & currentRow).Copy
End If
Next currentRow
End With
Application.ScreenUpdating = True
End Sub

VBA create names for columns

So I have a worksheet called "gar_nv" containing in its first row some strings that I'd like to define as names for my columns. For instance, first cell of column A is "Number", I'd like to refer to the column A(starting from the second cell) as "Number" instead of column "A".
Sub NameCol()
Dim LastRow As Long
Dim x As Long, Rng As Range
With gar_nv
For x = 1 To .UsedRange.Columns.Count
LastRow = Cells(Cells.Rows.Count, x).End(xlUp).Row
Set Rng = Cells(2, x).Resize(LastRow)
.Names.Add Name:=Cells(1, x), RefersTo:=Rng
Set Rng = Nothing
Next
End With
End Sub
When I test my code like this, it throws a 91 error, what am I doing wrong?
Sub test()
With gar_nv
For Each Rng In .Range("Number")
MsgBox (Rng.Value)
Next
End With
End Sub
Create Names for Columns of Data
gar_nv is the code name of a worksheet in the workbook containing this code.
Option Explicit
Sub NameColumnsData()
' Delete all previous names in the worksheet.
'DeleteAllWorksheetNames gar_nv
Dim hrg As Range ' header range
Dim drg As Range ' data range
Dim cCount As Long ' number of columns
With gar_nv.UsedRange
Set hrg = .Rows(1)
Set drg = .Resize(.Rows.Count - 1).Offset(1)
cCount = .Columns.Count
End With
Dim crg As Range
Dim c As Long
Dim cTitle As String
For c = 1 To cCount
cTitle = hrg.Cells(c).Value
Set crg = drg.Columns(c)
gar_nv.Names.Add cTitle, crg
' Of course, you can lose the variables and just do:
'gar_nv.Names.Add hrg.Cells(c).Value, drg.Columns(c)
Next c
MsgBox "Column data names created.", vbInformation
End Sub
Sub NameColumnsDataTEST()
Dim cCell As Range
With gar_nv
For Each cCell In .Range("Number").Cells
' Caution! If there are many cells it may take 'forever'.
'MsgBox cCell.Address(0, 0) & ": " & cCell.Value
' Rather print to the Immediate window (Ctrl+G):
Debug.Print cCell.Address(0, 0) & ": " & cCell.Value
Next
End With
End Sub
Sub DeleteAllWorksheetNames(ByVal ws As Worksheet)
Dim nm As Name
For Each nm In ws.Names
Debug.Print nm.Name, nm.RefersTo, "Deleted!"
nm.Delete
Next nm
End Sub

searching for data in a lot of sheets and copying entire row if data is found to a separate work sheet in VBA

Hi I'm relatively new to VBA and programing and im having an "overflow" issue with my code
I'm trying to to go through the first 31 work sheets search for the term "Power On" in column C and when it find a match copy the entire row and paste it into Sheet33 it was working at one point for just a single sheet but now i cant get it to work after modifying it for the first 31 sheets
any help would be greatly appreciated!
Sub test()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws1 As Worksheet
Dim I As Integer
LCopyToRow = 1
For I = 1 To 31
Set ws1 = ActiveSheet
LSearchRow = 1
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column C = "Power On", copy entire row to Sheet33
If Range("C" & CStr(LSearchRow)).Value = "Power On" Then
'Select row in ws1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet33 in next row
Sheets("Sheet33").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
'Go back to ws1
Sheets(ws1).Select
End If
LSearchRow = LSearchRow + 1
Wend
Exit Sub
Next I
End Sub
'Overflow' error happens when your declared data variable of a certain datatype can no longer hold the SIZE of the value you are putting in it.
Based on your code, LSearchRow and LCopyToRow are declared as INTEGER which can hold up to 32767 (rows). to fix this declare it as LONG instead of INTEGER:
Dim LSearchRow As Long
Dim LCopyToRow As Long
Here's an update to my answer. I made an alternative version of your code:
Sub GetPowerOn()
Dim ws As Worksheet
Dim wsResult As Worksheet
Dim nrow As Long
Dim actvCell As Range
Dim actvLrow As Long
Set wsResult = ThisWorkbook.Worksheets("Sheet33")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets '~Loop through the sheets of the workbook
If Not ws.Name = "Sheet33" Then '~As long as the sheet is not Sheet33, fire the search,copy,paste function below
actvLrow = ws.Range("A" & Rows.Count).End(xlUp).Row '~ Set the lastrow of the active sheet
For Each actvCell In ws.Range("C1:C" & actvLrow) '~ Loop through the cells of column C
If actvCell.Value = "Power On" Then '~Look for criteria
ws.Rows(actvCell.Row & ":" & actvCell.Row).Copy '~Copy the row that matches the criteria
nrow = wsResult.Range("A" & Rows.Count).End(xlUp).Offset(1).Row '~Get the lastrow empty row of the output sheet
wsResult.Range("A" & nrow).PasteSpecial xlPasteValuesAndNumberFormats '~Paste to the next empty row
Application.CutCopyMode = False
End If
Next actvCell
End If
Next ws
Application.ScreenUpdating = True
End Sub
' The reason you are getting the same sheet is you are setting WS1 to ActiveSheet
' 31 times in a row -- not getting the first 31 sheets.
' ActiveSheet is whatever sheet you last happened to have in focus. Unless you
' know you want that (almost never), you should not use it.
' You want to avoids things like copy / paste / select. These are slow.
' You also want to avoid processing things row by row.
' Here is an example that should do what you want.
Sub ThirtyOneFlavors()
Const PowerColNum = 3 ' if you are sure it will always be column 3
Dim WS1 As Worksheet, WS33 As Worksheet
Dim PowerColumn As Range, PowerCell As Range, FirstCell As Range, R As Long
Set WS33 = ThisWorkbook.Sheets("Sheet33") ' Maybe this could use a clever name
WS33.Cells.Delete ' only if you want this
' using ThisWorkbook avoids accidentally getting some other open workbook
For Each WS1 In ThisWorkbook.Sheets
' here, put the names of any sheets you don't want to process
If WS1.Name <> WS33.Name Then
Set PowerColumn = WS1.UsedRange.Columns(PowerColNum)
' I am assuming Power On is the whole column
Set PowerCell = PowerColumn.Find("Power On", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not PowerCell Is Nothing Then ' if you found something
' we need to keep track of the first one found,
' otherwise Excel will keep finding the same one repeatedly
Set FirstCell = PowerCell
End If
While Not PowerCell Is Nothing ' if you keep finding cells
R = R + 1 ' next row
'.Value will hold all of the values in a range (no need to paste)
WS33.Cells(R, 1).EntireRow.Value = PowerCell.EntireRow.Value
' get the next one
Set PowerCell = PowerColumn.Find("Power On", after:=PowerCell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If PowerCell.Address = FirstCell.Address Then
' if we found the first one again, kill the loop
Set PowerCell = Nothing
End If
Wend
End If
Next WS1
End Sub
'Consolidate' Data
Option Explicit
Sub ConsolidateData()
' Source
Const sfIndex As Long = 1
Const slIndex As Long = 31
Const sFirstCell As String = "C2"
Const sCriteria As String = "Power On"
' Destination
Const dIndex As Long = 33
Const dFirstCell As String = "A2" ' has to be column 'A' ('EntireRow')
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the initial destination cell.
Dim dws As Worksheet: Set dws = wb.Worksheets(dIndex)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCell)
Dim dCell As Range: Set dCell = RefLastCellInColumn(dfCell)
If dCell Is Nothing Then ' no data found
Set dCell = dfCell
Else ' data found
Set dCell = dCell.Offset(1)
End If
Dim sws As Worksheet
Dim srg As Range
Dim scrg As Range
Dim sCell As Range
Dim n As Long
Application.ScreenUpdating = False
' Process each source worksheet...
For n = sfIndex To slIndex
Set sws = wb.Worksheets(n)
Set scrg = RefColumn(sws.Range(sFirstCell))
' Test for data...
If Not scrg Is Nothing Then ' data in column found
' Process each cell in source column range...
For Each sCell In scrg.Cells
' Check current cell agains criteria. To ignore case,
' i.e. 'POWER ON = power on', 'vbTextCompare' is used.
If StrComp(CStr(sCell.Value), sCriteria, vbTextCompare) = 0 Then
' Combine current cell into current source range.
' The combining is restricted to per worksheet ('Union').
Set srg = RefCombinedRange(srg, sCell)
End If
Next sCell
' Test for matches...
If Not srg Is Nothing Then ' match found
' Copy. This will work only if all source cells contain values.
' If some of them contain formulas, the results may be mixed
' (some rows containing the formulas, some only values) due to
' the source range being non-contiguous.
' This is prevented by either not combining the cells or
' by using 'PasteSpecial'.
srg.EntireRow.Copy dCell
' Create a reference to the next destination cell.
Set dCell = dCell.Offset(srg.Cells.Count)
' Unreference source range (before processing next worksheet).
Set srg = Nothing
'Else ' no match found
End If
'Else ' no data in column found
End If
Next n
' Activate destination worksheet.
'If Not dws Is ActiveSheet Then dws.Activate
' Save workbook.
'wb.Save
Application.ScreenUpdating = True
MsgBox "Data consolidated.", vbInformation, "Consolidate Data"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the bottom-most non-empty cell
' in the one-column range from the first cell ('FirstCell')
' through the bottom-most cell of the worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefLastCellInColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set RefLastCellInColumn = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function
An alternative method using Find and `FindNext'
Option Explicit
Sub test()
Const MAX_SHT = 3
Const PASTE_SHT = 4
Const TERM = "Power On"
Const COL = "C"
Dim wb As Workbook, ws As Worksheet
Dim n As Integer, LastRow As Long, count As Long
Dim rngFound As Range, rngTarget As Range, sFirst As String
Set wb = ThisWorkbook
' check number of sheets
If wb.Sheets.count < MAX_SHT Then
MsgBox "Too few sheets", vbCritical
Exit Sub
End If
' copy destination
With wb.Sheets(PASTE_SHT)
LastRow = .Cells(Rows.count, COL).End(xlUp).Row
Set rngTarget = .Cells(LastRow + 1, "A")
End With
' first 31 sheets
For n = 1 To MAX_SHT
Set ws = wb.Sheets(n)
LastRow = ws.Cells(Rows.count, COL).End(xlUp).Row
With ws.Range("C1:C" & LastRow)
' search for term
Set rngFound = .Find(TERM, lookin:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
sFirst = rngFound.Address
Do
ws.Rows(rngFound.Row).EntireRow.Copy rngTarget
Set rngTarget = rngTarget.Offset(1)
Set rngFound = .FindNext(rngFound)
count = count + 1
Loop While rngFound.Address <> sFirst
End If
End With
Next
MsgBox count & " rows copied", vbInformation
End Sub
ok just try the following code
many fixes are made and speedUps
Sub test()
' in a x64 environement better forget Integers and go for Longs
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim ws1 As Worksheet
Dim I As Long
Dim vldRng As Range
Dim maxRw As Long
Dim maxClmn As Long
Dim rngDest As Range
'2 Lines to speed code Immensly. Don't use them while debugging
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LCopyToRow = 1
Set rngDest = ThisWorkbook.Sheets("Sheet33").Cells(1, 1)
'Set rngDest = ThisWorkbook.Sheets(33).Range("A1") 'Alternative 01
'Set rngDest = Sheets(33).Range("A1") 'Alternative 02
For I = 1 To 31
Set ws1 = ThisWorkbook.Sheets(I)
Set vldRng = ws1.UsedRange ' Get range used instead of searching entire Sheet
maxRw = vldRng.Rows.Count
maxClmn = vldRng.Columns.Count
For LSearchRow = 1 To maxRw
'If value in column C = "Power On", copy entire row to Sheet33
If vldRng.Cells(LSearchRow, 3).Value = "Power On" Then
'Select row in ws1 to copy
vldRng.Cells(LSearchRow, 1).Resize(1, maxClmn).Copy
'Paste row into Sheet33 in next row
rngDest.Offset(LCopyToRow - 1, 0).PasteSpecial xlPasteValues
LCopyToRow = LCopyToRow + 1
End If
Next LSearchRow
Next I
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

What is the fastest way to pull data from one sheet to another using VBA

I have and excel file with 2 tabs, one is 166K rows and the other is 400K rows. Previously we were manually performing vlookups to pull data from the 400k row tab into the 166k row tab. I want to automate this some using VBA but am having issues with speed.
I tried an IF formula but that ran for over 30 minutes before I killed the process
For i = 2 To Assign.UsedRange.Rows.Count
For x = 2 To HR.UsedRange.Rows.Count
If Assign.Cells(i, 1 ) = HR.Cells(x,1) Then
Assign.Cells(i, 9) = HR.Cells(x, 3)
End If
Next x
Next i
and now I'm trying a vlookup for VBA but that also is taking a long time.
For x = 2 To Assign.UsedRange.Rows.Count
On Error Resume Next
Worksheets("Assignments").Cells(x, 9).Value =
Application.WorksheetFunction.VLookup(Worksheets("Assignments").Cells(x, 5).Value,
Worksheets("Workforce").Range("A:AX"), 5, 0)
On Error GoTo 0
Next x
any suggestions on how to speed this up? I tried using Access but the files were too big.
A VBA Lookup
This took roughly 13 seconds on my machine (Windows 10, Office 2019 64bit) for 400k vs 160k of integers.
An optimized (using arrays and Application.Match applied to the lookup column range) Match version took the same amount of time for 10 times fewer data.
Since your data probably isn't integers, your feedback is highly appreciated.
Adjust the values in the constants section.
Option Explicit
Sub VBALookup()
Const sName As String = "Workforce" ' Source Worksheet Name
Const slFirst As String = "E2" ' Source Lookup Column First Cell Address
Const svCol As String = "I" ' Source Value Column
Const dName As String = "Assignments" ' Destination Worksheet Name
Const dlFirst As String = "E2" ' Destination Lookup First Cell Address
Const dvCol As String = "I" ' Destination Value Column
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create references to the Source Ranges.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(slFirst)
Dim slrg As Range: Set slrg = RefColumn(sfCell) ' lookup range
If slrg Is Nothing Then Exit Sub
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol) ' read value
' Create references to the Destination Ranges.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dlFirst)
Dim dlrg As Range: Set dlrg = RefColumn(dfCell) ' lookup value
If dlrg Is Nothing Then Exit Sub
Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol) ' write value
' Write the 'INDEX/MATCH' formula to a variable.
Dim dFormula As String
dFormula = "=IFERROR(INDEX('" & sName & "'!" & svrg.Address(, 0) _
& ",MATCH(" & dfCell.Address(0, 0) _
& ",'" & sName & "'!" & slrg.Address(, 0) & ",0)),"""")"
' Take a look in the Immediate window ('Ctrl + G')
'Debug.Print "Source", slrg.Address(, 0), svrg.Address(, 0)
'Debug.Print "Destination", dlrg.Address(, 0), dvrg.Address(, 0)
'Debug.Print "Formula", dFormula
' Write the formula to the Destination Value Range
' and convert the formulas to values.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
dvrg.Formula = dFormula
dvrg.Value = dvrg.Value
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first cell
' of a range ('rg') through the bottom-most non-empty cell
' of the range's column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim rData As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
Else
rData = rg.Value
End If
GetRange = rData
End Function
I would try with the find method instead of an inner loop. You have just to customize your file references and ranges.
Sub FindMatches()
Dim shtOld As Worksheet, shtNew As Worksheet
Dim oldRow As Integer
Dim newRow As Integer
Dim i As Integer, id, f As Range
i = 1
Set shtOld = ThisWorkbook.Sheets("Assign")
Set shtNew = ThisWorkbook.Sheets("HR")
For oldRow = 2 To shtOld.UsedRange.Rows.Count
id = shtOld.Cells(oldRow, 1)
Set f = shtNew.Range("A1:A1000").Find(id, , xlValues, xlWhole)
If Not f Is Nothing Then
With shtOld.Rows(i)
.Cells(1).Value = shtOld.Cells(oldRow, 1)
End With
i = i + 1
End If
Next oldRow
End Sub

Find column by name and convert it vba

How can I find in vba column by name ex. "Test1" and convert whole column to number format?
as far i manage to find the cell:
Worksheets("Sheet1").Cells.Find(What:="Test1")
Something like this:
Public Sub Test()
Dim r As Range
Set r = FindColumn("Test1")
If Not r Is Nothing Then
r.NumberFormat = "#,##0.00"
End If
End Sub
Public Function FindColumn(HeaderName As String) As Range
Dim FndCol As Range
With ThisWorkbook.Worksheets("Sheet1")
Set FndCol = .Cells.Find(HeaderName, .Cells(1, 1), xlValues, xlWhole)
If Not FndCol Is Nothing Then
Set FindColumn = FndCol.EntireColumn
End If
End With
End Function
Data Column Number Format
This solution will print the range addresses at the various stages of the code to the Immediate window (CTRL+G).
For example, in the range A1:J10 containing data, if cell C1 is equal to Test1, it will apply the number format to the range C2:C10.
Option Explicit
Sub applyColumnNumberFormat()
Const wsName As String = "Sheet1"
Const HeaderRow As Long = 1
Const Header As String = "Test1"
Const nFormat As String = "#.00"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim hrg As Range: Set hrg = ws.Rows(HeaderRow) ' Header Row Range
Debug.Print "Header Row Range: " & hrg.Address(0, 0)
Dim hCell As Range ' Header Cell Range
Set hCell = hrg.Find(Header, hrg.Cells(hrg.Cells.Count), _
xlFormulas, xlWhole)
If Not hCell Is Nothing Then
Debug.Print "Header Cell Address: " & hCell.Address(0, 0)
Dim lCell As Range ' Last Non-Empty Cell Range
Set lCell = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Debug.Print "Last Non-Empty Cell: " & lCell.Address(0, 0)
Dim drg As Range ' Destination Range - Occupied Cells Below the Header
Set drg = hCell.Resize(lCell.Row - hCell.Row).Offset(1)
Debug.Print "Destination Range: " & drg.Address(0, 0)
drg.NumberFormat = nFormat
Else
Debug.Print "Header '" & Header & "' not found."
End If
End Sub
The following code assumes your column headings are on row 1.
The Find function returns a range object. You can use the Column property of the range to identify the column you want to format.
Dim r As Range
Dim col As Integer
Set r = Worksheets("Sheet1").Rows(1).Find(What:="Test")
If r Is Nothing Then
'Column heading not found
Else
col = r.Column
Worksheets("Sheet1").Columns(col).NumberFormat = "0.00"
End If

Resources