I know little about vba so I am hoping someone can help me.
I have the following code below, it "fill blank cells in column with value above" and works fine.
I need to use it on NON-contiguous coloumns.
Is there a way to add a loop to it so that it will run on [B D H I] columns?
I have tryed to puzzel this out have not got anywhere
Thanks
Sub FillColBlanks()
'by Dave Peterson 2004-01-06
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html
Dim wks As Worksheet
Dim rng As Range
Dim Lastrow As Long
Dim col As Long
Set wks = ActiveSheet
With wks
'col = ActiveCell.Column
'or
col = .Range("G2").Column
Set rng = .UsedRange 'try to reset the lastcell
Lastrow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Nothing
On Error Resume Next
Set rng = .Range(.Cells(2, col), .Cells(Lastrow, col)) _
.Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No blanks found"
Exit Sub
Else
rng.FormulaR1C1 = "=R[-1]C"
End If
'replace formulas with values
With .Cells(1, col).EntireColumn
.Value = .Value
End With
End With
End Sub
you could try the below:
Sub FillColBlanks(sColRange as string)
'by Dave Peterson 2004-01-06
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html
Dim wks As Worksheet
Dim rng As Range
Dim Lastrow As Long
Dim col As Long
Set wks = ActiveSheet
With wks
'col = ActiveCell.Column
'or
col = .Range(sColRange).Column
Set rng = .UsedRange 'try to reset the lastcell
Lastrow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Nothing
On Error Resume Next
Set rng = .Range(.Cells(2, col), .Cells(Lastrow, col)) _
.Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "No blanks found"
Exit Sub
Else
rng.FormulaR1C1 = "=R[-1]C"
End If
'replace formulas with values
With .Cells(1, col).EntireColumn
.Value = .Value
End With
End With
End Sub
so you call that procedure like this:
Call FillColBlanks("B1")
Call FillColBlanks("D1")
Call FillColBlanks("H1")
Call FillColBlanks("I1")
Related
I need to Filter/Show data on the visible cells only on my dataset.
The using of AutoFilter is very fast, But it has a downside that it show any hidden rows on the respective criteria. .
Although I am using arrays and Application optimization on the below code , but it gets very slow if the range starts to be bigger.
With just 100 rows, it finished on 1.12 sec and with 1000 rows it finished on 117.47 sec !
In advance, I am grateful for all your support.
Option Explicit
Option Compare Text
Sub Filter_on_Visible_Cells_Only()
Dim t: t = Timer
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Dim i As Long, HdRng As Range
Dim j As Long, k As Long
SpeedOn
Set ws1 = ThisWorkbook.ActiveSheet
Set ws2 = ThisWorkbook.Sheets("Platforms")
Set rng1 = ws1.Range("D3:D" & ws1.Cells(Rows.Count, "D").End(xlUp).Row) 'ActiveSheet
Set rng2 = ws2.Range("B3:B" & ws2.Cells(Rows.Count, "A").End(xlUp).Row) 'Platforms
arr1 = rng1.Value2
arr2 = rng2.Value2
For i = 1 To UBound(arr1)
If ws1.Rows(i + 2).Hidden = False Then '(i + 2) because Data starts at Row_3
For j = LBound(arr1) To UBound(arr1)
For k = LBound(arr2) To UBound(arr2)
If arr1(j, 1) <> arr2(k, 1) Then
addToRange HdRng, ws1.Range("A" & i + 2) 'Make a union range of the rows NOT matching criteria...
End If
Next k
Next j
End If
Next i
If Not HdRng Is Nothing Then HdRng.EntireRow.Hidden = True 'Hide not matching criteria rows.
Speedoff
Debug.Print "Filter_on_Visible_Cells, in " & Round(Timer - t, 2) & " sec"
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Sub SpeedOn()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
End Sub
Sub Speedoff()
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Ok, if you want to use this, you have to use the autofilter with vba as well. There is no event which fires on usage of the autofilter through the excel UI (except you work with some help of formulas in hidden worksheets, like described here Link).
But if you want to use it in vba, you could simply use this, this should help and if i try it on that 167 cells, it works pretty fast:
Sub m()
Dim rngTemp As Range
For Each c In Range("a1:a167")
If c.EntireRow.Hidden Then
If rngTemp Is Nothing Then
Set rngTemp = c
Else
Set rngTemp = Union(rngTemp, c)
End If
End If
Next c
Range("A1:A167").AutoFilter Field:=1, Criteria1:="10" ' your autofilter values
rngTemp.EntireRow.Hidden = False
End Sub
Compare Values Using Application.Match
Sub Filter_on_Visible_Cells_Only()
Dim t: t = Timer
Dim sws As Worksheet, srg As Range
Dim dws As Worksheet, drg As Range, dCell As Range, hdrg As Range
SpeedOn
Set sws = ThisWorkbook.Sheets("Platforms")
Set srg = sws.Range("B3", sws.Cells(sws.Rows.Count, "B").End(xlUp))
Set dws = ThisWorkbook.ActiveSheet
Set drg = dws.Range("D3", dws.Cells(dws.Rows.Count, "D").End(xlUp))
Set drg = drg.SpecialCells(xlCellTypeVisible)
For Each dCell In drg.Cells
If IsError(Application.Match(drg.Value, srg, 0)) Then
addToRange hdrg, dCell
End If
Next dCell
If Not hdrg Is Nothing Then hdrg.EntireRow.Hidden = True
Speedoff
Debug.Print "Filter_on_Visible_Cells, in " & Round(Timer - t, 2) & " sec"
End Sub
This is code the internet and I came up with. Please could you tell me what I’m doing wrong? I keep getting an error that says “can’t use a loop without a do”
Sub additions ()
Range(“BI1”) = “Comments”
Range(“V2”).Select
Do until IsEmpty(ActiveCell)
If (Range(ActiveCell) = “DM”) Then
ActiveCell.Offset(0,39).Select
Range(ActiveCell) = “Developed Markets”
ActiveCell.Offset(1,-39).Select
End If
Loop
End Sub
Add String to One Column If Another String in Another Column
Option Explicit
Sub Additions()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range
Set srg = ws.Range("V2", ws.Cells(ws.Rows.Count, "V").End(xlUp))
Dim drg As Range: Set drg = srg.EntireRow.Columns("BI")
ws.Range("BI1").Value = "Comments"
Dim sCell As Range
Dim r As Long
For Each sCell In srg.Cells
r = r + 1
If CStr(sCell.Value) = "DM" Then ' is a match
drg.Cells(r).Value = "Developed Markets"
'Else ' is not a match; do nothing
End If
Next sCell
MsgBox "Additions finished.", vbInformation
End Sub
How to find sheet if not found in this workbook, and if the array column cell is empty, then find in next cell. I have a working code kindly review it.
Public Sub customersheetpaste()
Dim wsMain As Worksheet
Dim wsName As Worksheet
Dim lrowMain As Long
Dim lrowName As Long
Dim i As Long
Dim j As Integer
Dim arr As Variant
Set wsMain = ThisWorkbook.Worksheets("Main Sheet")
lrowMain = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
arr = [transpose(A4:A30)] <------want to search the whole A column
For i = 1 To UBound(arr)
For j = 4 To lrowMain
If wsMain.Cells(j, 1).Value = arr(i) Then
wsMain.Range("B" & j & ":H" & j).Copy
Set wsName = ThisWorkbook.Worksheets(arr(i)) <--- gave error if cell is empty so i gave error handler
On Error GoTo errorhandler
With wsName
.Activate
lrowName = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(lrowName + 1, 1).Select
.PasteSpecial xlPasteValuesAndNumberFormats
End With
wsMain.Activate
End If
Next
Next
errorhandler:
Application.CutCopyMode = False
wsMain.Cells(1, 1).Select
Exit Sub
End Sub
Thankyou
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs
I am using the following code to search in the A column of a row for a name. If the name is found, it is placed in a column 2 over. I am trying to search against a list of names rather than one name. The names are listed in sheet1, I am searching text stored in column A on sheet4. Each row has a paragraph of text I want to search. When a match is found, the matching name(s) is put in cell c of the same row.
Sub test()
Dim ws1, ws2 As Worksheet, rng1, rng2, cel1, cel2 As Range
Dim i, lrow As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet4")
'i only assumed that your data is both in column A of sheet 1 and 2
lrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = ws1.Range("A1:A" & lrow) 'this contains the names
lrow = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set rng2 = ws2.Range("A1:A" & lrow) 'this contains list of text you want to search
i = 0
For Each cel2 In rng2
For Each cel1 In rng1
If InStr(cel1.Value, cel2.Value) <> 0 Then cel1.Copy ws2.Range("c1").Offset(i, 0): i = i + 1
Next cel1
Next cel2
End Sub
Cheers!
If my comment is correct then this should work for you:
say I start with this set up:
I would first add my look up values to a named range as follows:
then you can add this code:
Sub Sample()
Application.ScreenUpdating = False
With Range("A2", Range("A" & Rows.Count).End(xlUp)).Offset(, 2)
.FormulaR1C1 = _
"=IFERROR(LOOKUP(1E+100,SEARCH(LookUpValues,RC[-2]),LookUpValues),"""")"
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
and this should result in the following:
this is another way to get what you want but not really using formula.
Option Explicit
Sub test()
Dim ws1, ws2 As Worksheet, rng1, rng2, cel1, cel2 As Range
Dim i, lrow As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'i only assumed that your data is both in column A of sheet 1 and 2
lrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = ws1.Range("A1:A" & lrow) 'this contains the names
lrow = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set rng2 = ws2.Range("A1:A" & lrow) 'this contains list of text you want to search
i = 0
For Each cel2 In rng2
For Each cel1 In rng1
If InStr(cel1.Value, cel2.Value) <> 0 Then cel1.Copy ws1.Range("B1").Offset(i, 0): i = i + 1
Next cel1
Next cel2
End Sub
I proposed above approach since you are open to using VBA.
hope this is what or somewhat close to what you want.