I have data that comes like this:
bear 94
cat 25
alligator 53
impala 55
elk 56
fox 47
dog 13
gecko 18
jaguar 32
hound 59
...but I would like to have two 'copies' of this table on the same Excel sheet, the first sorting on the first column, so like:
alligator 53
bear 94
cat 25
dog 13
elk 56
fox 47
gecko 18
hound 59
impala 55
jaguar 32
...and the second table would be again the same data, but sorting on the second column, like so:
bear 94
hound 59
elk 56
impala 55
alligator 53
fox 47
jaguar 32
cat 25
gecko 18
dog 13
...but the catch is that I don't want to have to use the actual 'sort' feature in excel! This may sound crazy, but I have a much larger application where manually sorting would be very tedious. If possible, I'd like to have a formula that does this automatically, but I could use an excel-VBA macro too. Any ideas?
OK, here's the solution I came up with. Maybe there's a more elegant way, please let me know! Thanks guys :)
If you got a lot of sheets, VBA may be the way to go. The following code is one way to do this. It loops through all the sheets in a workbook and sorts each table (assuming that the sheet only holds that one table which begins in cell A1) by the variables you define in SortBy1 and SortBy2.
It will sort the table by SortBy2, copy this beneath the original table and then sort the original table once more by SortBy1. This should work as long as the variables you want to sort by are all named the same throughout the entire workbook.
Option Explicit
Sub SortAndCopy()
Dim ws As Worksheet
Dim DataRng As Range
Dim SortRng1 As Range, SortRng2 As Range
Dim nr As Integer, nc As Integer, i As Integer
Dim DataArr As Variant
Dim SortBy1 As String, SortBy2 As String
Dim nBelowTable As Integer
Dim HeaderFound As Integer
SortBy1 = "Animal" '<~~ Define the first variable to sort by
SortBy2 = "Count" '<~~ Define the second variable to sort by
nBelowTable = 5 '<~~ Defines how far below the original table you want to place a copy
Application.ScreenUpdating = False
'Loops through each individual sheets
For Each ws In ActiveWorkbook.Sheets
HeaderFound = 0
'Determines data range
nr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
nc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set DataRng = ws.Range("A1:" & ws.Cells(nr, nc).Address)
'Determines ranges to sort by
For i = 1 To nc Step 1
If LCase(ws.Cells(1, i).Value) = LCase(SortBy1) Then
Set SortRng1 = ws.Range(ws.Cells(1, i).Address & ":" & ws.Cells(nr, i).Address)
HeaderFound = HeaderFound + 1
End If
If LCase(ws.Cells(1, i).Value) = LCase(SortBy2) Then
Set SortRng2 = ws.Range(ws.Cells(1, i).Address & ":" & ws.Cells(nr, i).Address)
HeaderFound = HeaderFound + 1
End If
Next i
'Exit if header not found
If Not HeaderFound = 2 Then
MsgBox "One of the header variables could not be found in the sheet " & ws.Name & ". No further sheets will be processed!", vbCritical
Exit Sub
End If
'Sorts table by SortBy2
With ws.Sort.SortFields
.Clear
.Add Key:=SortRng2, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With ws.Sort
.SetRange DataRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Places copy of this table underneath the original
ReDim DataArr(1 To nr, 1 To nc)
DataArr = DataRng
ws.Range(ws.Cells(nr + nBelowTable, 1).Address, ws.Cells(2 * nr + nBelowTable - 1, nc).Address) = DataArr
'Sorts table by SortBy1
With ws.Sort.SortFields
.Clear
.Add Key:=SortRng1, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With ws.Sort
.SetRange DataRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next ws
Application.ScreenUpdating = False
End Sub
Get MOREFUNC addon for Excel and use VSORT()
MOREFUNC ADDON
Morefunc Addon is a free library of 66 new worksheet functions.
HERE is some information (by original author)
here is the last working download link I found
here is a good installation walk-through video
Move to Google sheets and simply use SORT()
Related
I need to create an excel sheet which contains a visual representation of a bit array. Presently I test the bit value and update the cell contents
For h = 1 To 128
value = Mid(array, h,1)
If value = "1" Then
xl.Application.Sheets("Sheet1").Cells(129 - h,5).value = "X"
Else
xl.Application.Sheets("Sheet1").Cells(129 - h,5).value = ""
End If
Next
If I add a WScript.Sleep 100 before Next then the output result in the excel sheet is correct.
If not, then the X's are in the wrong places.
Initially I thought that it was Excel that was slow, so I tried making a CSV file that I could simply import later, but with the same results: too fast and the X's are in the wrong positions, slow it down and they are correct.
There are around 128 of these 128bit arrays, and if each takes 3 ~ 5 seconds then making this sheet will take forever.
Does anyone know how I can achieve this quickly? I am open to other ideas/solutions (with VBS) outputting the excel file.
Thanks!
Try putting the array into the range in one go, like this
ReDim dat(1 To 128, 1 To 1)
For h = 1 To 128
v = Mid$(arr, h, 1)
dat(129 - h, 1) = IIf(v = "1", "X", "")
Next
xl.Application.Sheets("Sheet1").Cells(1, 5).Resize(128, 1).Value = dat
This worked for me (tested in vbscript rather than vba).
As it uses an array, the "" output as part of an IF is redundant as the array is blank, so it is only necessary to write the X when the bit is 1.
Dim StrArr
Dim xl
Set xl = CreateObject("excel.application")
Set wb = xl.Workbooks.Add
'sample array
StrArr = "1100111011001110110011101100111011001110110011101100111011001110110011101100111011001110110011101100111011001110110011101100111"
Dim X(128, 1 )
For lngrow = 1 To UBound(X)
If Mid(StrArr, lngrow, 1) = "1" Then X(lngrow, 0) = 1
Next
wb.Sheets(1).Cells(1, 5).Resize(UBound(X), 1).Value = X
xl.Visible = True
I have developed a small VBA macro in Excel that's supposed to add the values of cells in row 15 to the values of cells in row 6 during workbook change (in my case entering a number in row 15 and pressing tab).
Initially, I developed and used it in Excel 2013, then I have switched to Mac and have since used it in Excel for Mac 2011. Now, I have installed Excel for Mac 2016 and all of a sudden, the macro doesn't work anymore.
This is the script:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C15:H15")) > 0 Then
Call copySub
End If
End Sub
Sub copySub()
Sheets("sheet1").Protect , UserInterFaceOnly:=True
For i = 3 To 8
Cells(6, i).Value = Cells(6, i).Value + Cells(15, i).Value
Cells(15, i).Value = 0
Next i
End Sub
When I enter a value and press tab in Excel 2016, I get the runtime error 91 "Object variable or With block variable not set". The error seems to occur in the line:
Cells(6, i).Value = Cells(6, i).Value + Cells(15, i).Value
I have also tried to store the sum in a variable before assigning it to Cells(6, i).Value, but that didn't help either.
Did Microsoft change the logic of the sheet protection, especially with the parameter UserInterFaceOnly set to true? Or what's going on here?
I hope you can help me.
Thanks,
chuky
Are you sure you've copied this code correctly? There's no way it would work in any version of Excel.
Your problems are these:
Intersect returns a Range object so your code would throw a 91 error.
There's most likely a case error in your line Sheets("sheet1").Protect ... as it's probably called "Sheet1". If so, this would throw a 91 error.
If you changed that worksheet name from "sheet1", it'd throw a 91 error.
Why are you only protecting the sheet at Worksheet_Change. This should really be done in Workbook_Open? And if you do that, how does the user change the cells without specific cells being free from protection?
It's unclear which worksheets you're referring to and where the copySub routine is held. I've updated your code as it is to remove the main errors and written in the capacity to nominate your worksheet - you'll have to adjust that as you wish. Good luck.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Target.Worksheet
If Not Intersect(Target, ws.Range("C15:H15")) Is Nothing Then
Call copySub(ws)
End If
End Sub
Sub copySub(ws As Worksheet)
ws.Protect , UserInterFaceOnly:=True
Application.EnableEvents = False
For i = 3 To 8
ws.Cells(6, i).Value = ws.Cells(6, i).Value + ws.Cells(15, i).Value
ws.Cells(15, i).Value = 0
Next i
Application.EnableEvents = True
End Sub
Introduction
I already have a working solution to the problem this question will describe. Being new to programming, I think my solution is fairly ugly, but: 1) I am not sure that’s true, and 2) I don’t see a more elegant solution after a solid week reading around the internet studying. Since I can easily solve the problem on an ad hoc basis using Pivot Tables and the subject spreadsheet is common report style, I am thinking that many others have already solved this problem (but I haven’t found it or know the keywords to search for). I will provide the raw data, the desired output, the code I currently have working, and some alternatives that I’ve looked at, but didn’t use and why. I am asking you for a better programming approach -- if you see one -- or at least validation that my method was reasonably as efficient as it could be done. Thank you.
The Raw Data
Below is an example of a report which contains data to be summarized:
Report #| Assignee| Type of Report| Department| Status
1 | Shannon| Ad hoc| Accounting| Declined
2 | Shannon| Ad hoc| Accounting| Completed
3 | Shannon| Change| Accounting| New
4 | Shannon| Change| Shipping| In Progress
5 | Shannon| Training| Shipping| Declined
6 | Shannon| Training| CustService| Completed
7 | Shannon| Training| CustService| New
8 | Jason| Ad hoc| CustService| In Progress
9 | Jason| Change| CustService| Declined
10 | Jason| Ad hoc| Accounting| Completed
11 | Jason| Training| Accounting| New
12 | Thomas| Training| Accounting| In Progress
13 | Jason| Change| Shipping| Declined
14 | Jason| Ad hoc| Shipping| Completed
15 | Thomas| Ad hoc| CustService| New
16 | Jason| New| CustService| In Progress
17 | Thomas| New| CustService| Declined
18 | Thomas| Change| CustService| Completed
19 | Thomas| Ad hoc| Shipping| New
20 | Thomas| Change| Shipping| In Progress
-Continues in similar fashion until:-
545 | Phyllis| New| Accounting| Declined
Desired Output
The data needs to be summarized in a manner similar to what is below. That is, it is filtered by Assignee name, and a count of the subcategories is the output for each parent category. (Note: This output could be easily obtained using a Pivot Table ad hoc, but I want to put it into a running table that builds over time programmatically for trend analysis.)
Shannon: Type of Report Department Status
Ad hoc= 25 Accounting= 45 Declined = 12
Change= 13 CustService= 2 In Progress= 24
Training= 3 Shipping= 75 New= 56
New= 81 Completed= 30
Jason: Type of Report Department Status
Ad hoc= 12 Accounting= 21 Declined = 0
Change= 3 CustService= 23 In Progress= 12
Training= 20 Shipping= 4 New= 12
New= 13 Completed= 24
-Continues for each "Assignee"-
The summarizing I am doing is very similar to what you get from a PivotTable, and that's currently how the manual process gets the data. I need to get the data, however, and put into a daily tracking table which retains the historical counts and is used for trend analysis on each assignee, so a PivotTable by itself isn’t a solution.
Currently Working Code
This is the entire piece of working code, including two subs that are called which are appended to the end:
Sub CollateData()
Dim HdrNm As New Collection 'Collection used to read and reference column indices.
'Variables used for referencing the "Assigned To" column
Dim Assignee As New Scripting.Dictionary
Dim nmAssignee As New Scripting.Dictionary
Dim Asgn As String
Dim a As Integer
Dim aKey As Variant
'Variables used for referencing the "Type of Report" column
Dim TypRep As New Scripting.Dictionary
Dim nmTypRep As New Scripting.Dictionary
Dim arrTypRep() As Integer
Dim Typ As String
Dim t As Integer
'Variables used for referencing the "Department" column
Dim Dept As New Scripting.Dictionary
Dim nmDept As New Scripting.Dictionary
Dim arrDept() As Integer
Dim Bus As String
Dim b As Integer
'Variables used for referencing the "Task Status" column
Dim TskStatus As New Scripting.Dictionary
Dim nmTskStatus As New Scripting.Dictionary
Dim arrTskStatus() As Integer
Dim Tsk As String
Dim s As Integer
'Other variables
Dim DataWS As Worksheet
Dim ScratchWS As Worksheet
Dim lastrow As Integer, x As Integer
Set DataWS = ThisWorkbook.Worksheets("SheetWithRawData")
lastrow = DataWS.Cells(Rows.Count, 11).End(xlUp).Row
Call ReadHeaderRow(DataWS, HdrNm) 'Fills the HdrNm collection with column index using column headers for keys
'Initialize variables for the loop that follows
a = 1
t = 1
b = 1
s = 1
'This next seciont/first loop goes through the report to identify a unique list of assignees and category lists _
' which need to be summed. These lists will be used to ReDim the 2-dimensional arrays to appropriate _
' size, as well as reference the elements of the 2D array(s).
'
' NOTE: I am using the seemingly duplicative Dictionaries (e.g. TypRep & nmTypeRep) in order to have _
' access to the category as both a string and as an integer/index.
For x = 2 To lastrow
If Not Assignee.Exists(DataWS.Cells(x, HdrNm("Assigned to")).Value) Then
Assignee.Add DataWS.Cells(x, HdrNm("Assigned to")).Value, a
nmAssignee.Add a, DataWS.Cells(x, HdrNm("Assigned to")).Value
a = a + 1
End If
If Not TypRep.Exists(DataWS.Cells(x, HdrNm("Type of Report")).Value) Then
TypRep.Add DataWS.Cells(x, HdrNm("Type of Report")).Value, t
nmTypRep.Add t, DataWS.Cells(x, HdrNm("Type of Report")).Value
t = t + 1
End If
If Not Dept.Exists(DataWS.Cells(x, HdrNm("Department")).Value) Then
Dept.Add DataWS.Cells(x, HdrNm("Department")).Value, b
nmDept.Add b, DataWS.Cells(x, HdrNm("Department")).Value
b = b + 1
End If
If Not TskStatus.Exists(DataWS.Cells(x, HdrNm("Task Status")).Value) Then
TskStatus.Add DataWS.Cells(x, HdrNm("Task Status")).Value, s
nmTskStatus.Add s, DataWS.Cells(x, HdrNm("Task Status")).Value
s = s + 1
End If
Next x
'Assign the appropriate dimensions to the following 2D arrays
ReDim arrTypRep(1 To Assignee.Count, 1 To TypRep.Count)
ReDim arrDept(1 To Assignee.Count, 1 To Dept.Count)
ReDim arrTskStatus(1 To Assignee.Count, 1 To TskStatus.Count)
'The following, second loop now goes through and sums up the count of each category element for each _
' Assignee. Using this technique, I only go through the list/report once (or twice, if you consider _
' the previous loop to dimension the arrays) in order to tabulate the desired data.
For x = 2 To lastrow
Asgn = DataWS.Cells(x, HdrNm("Assigned to")).Value
Typ = DataWS.Cells(x, HdrNm("Type of Report")).Value
Bus = DataWS.Cells(x, HdrNm("Department")).Value
Tsk = DataWS.Cells(x, HdrNm("Task Status")).Value
arrTypRep(Assignee.item(Asgn), TypRep.item(Typ)) = arrTypRep(Assignee.item(Asgn), TypRep.item(Typ)) + 1
arrDept(Assignee.item(Asgn), Dept.item(Bus)) = arrDept(Assignee.item(Asgn), Dept.item(Bus)) + 1
arrTskStatus(Assignee.item(Asgn), TskStatus.item(Tsk)) = arrTskStatus(Assignee.item(Asgn), TskStatus.item(Tsk)) + 1
Next x
'Now to generate the output of the data we collected:
On Error Resume Next
Application.DisplayAlerts = False
With ThisWorkbook
.Worksheets("DesiredOutput").Delete
.Worksheets.Add after:=.Worksheets(1)
End With
Application.DisplayAlerts = True
On Error GoTo 0
Set ScratchWS = ThisWorkbook.ActiveSheet
ScratchWS.Name = "DesiredOutput"
x = 1
'Loop through each Assignee and dump out the collected counts
For Each aKey In Assignee
Call OutputData("Type of Report", Assignee, nmAssignee, aKey, TypRep, nmTypRep, arrTypRep, x)
Call OutputData("Department", Assignee, nmAssignee, aKey, Dept, nmDept, arrDept, x)
Call OutputData("Task Status", Assignee, nmAssignee, aKey, TskStatus, nmTskStatus, arrTskStatus, x)
Next aKey
Range("B1").ColumnWidth = 3
Range("A1, C1").EntireColumn.AutoFit
End Sub
****************************************************************************
****************************************************************************
Sub OutputData(Title As String, Assignee As Scripting.Dictionary, nmAssignee As Scripting.Dictionary, _
aKey As Variant, ReportCategory As Scripting.Dictionary, nmReportCategory As Scripting.Dictionary, _
arrCategory() As Integer, x As Integer)
Dim CatKey As Variant
With Cells(x, 2)
.Value = Title
.Font.Bold = True
End With
x = x + 1
For Each CatKey In ReportCategory
Cells(x, 1).Value = nmAssignee.item(Assignee.item(aKey))
Cells(x, 3).Value = nmReportCategory.item(ReportCategory.item(CatKey))
Cells(x, 4).Value = arrCategory(Assignee.item(aKey), ReportCategory.item(CatKey))
x = x + 1
Next CatKey
x = x + 1
End Sub
**************************************************************************
**************************************************************************
Private Sub ReadHeaderRow(TargetWS As Worksheet, HdrNm As Collection)
Dim lastcolumn As Integer
Dim x As Integer
lastcolumn = TargetWS.Cells(1, Columns.Count).End(xlToLeft).Column
For x = 1 To lastcolumn
HdrNm.Add TargetWS.Cells(1, x).Column, TargetWS.Cells(1, x).Value
Next x
End Sub
Other Possible Solutions Considered/Discarded
Looping through list for each Assignee
I thought about generating a dictionary/collection of assignees and then looping through the report gathering the data for each assignee on each pass, but the number of assignees could change (go up), and the report list could go up, and thus many extraneous passes through the list.
Jagged Arrays/Collections/Dictionaries
I was excited when I first learned that I could do a dictionary of dictionaries (array of arrays, etc), but as I understand it, I can't use the first dictionary for assignees (1st Dimension) and a second dictionary for all of one category (e.g. Type of Report) as the second dimension. I would actually need to create a separate dictionary for each assignee and category. In other words, if I had just one category (Type of Report) and 15 assignees, I would actually need to create 16 dictionaries: 1st dictionary would be "Assignee" --the assignee's name as the key, and 2nd through 16th dictionaries (TypRep1 through TypRep15) as the items corresponding to the keys in dictionary Assignee. Plus, I cannot create the dictionaries dynamically as the number of Assignees might change, so this method was out for me, unless I've misunderstood something important (always possible). My knowledge of jagged datatypes comes from here: http://bytecomb.com/collections-of-collections-in-vba/
Custom Data Type
I haven't tried this because I just came across it, and I don't know much about it, but maybe this problem would be solved as a custom data type. I'm going to go read about them more, but perhaps that's a better solution in a way I do not yet understand.
Concluding Statement
I know this was a lot to read, sorry. Thanks for sticking this far. I would greatly appreciate any suggestions on how to achieve what my code above does achieve. I feel confident that the reason I haven't found a better way is that this problem's solution is obvious to everyone but me, and it seems like it would be something anyone coding in VBA/Excel would come across with some frequency. Thank you for your helpful input.
We use objects in programming. Most computers have Excel, so you could get excel to do it for you.
Windows come with an object, which I think of as a datatype. A created in memory, disconnected recordset.
So you would do
rs.filter = "Assignee='Shannon' AND Status='Cancelled'"
then
msgbox rs.recordcount
Gives you the number.
Or you can sort and enumerate.
This cuts lines from the top or bottom of a file.
cscript scriptname.vbs "" t x 5 <infile.txt >outfile.txt
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "LineNumber", 4
.Fields.Append "Txt", 201, 5000
.Open
LineCount = 0
Do Until Inp.AtEndOfStream
LineCount = LineCount + 1
.AddNew
.Fields("LineNumber").value = LineCount
.Fields("Txt").value = Inp.readline
.UpDate
Loop
.Sort = "LineNumber ASC"
If LCase(Arg(1)) = "t" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber < " & LCase(Arg(3)) + 1
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber > " & LCase(Arg(3))
End If
ElseIf LCase(Arg(1)) = "b" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber > " & LineCount - LCase(Arg(3))
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber < " & LineCount - LCase(Arg(3)) + 1
End If
End If
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
One approach for you would be to put your 4 criteria into 4 arrays- Assignee, Status, Dept, theotherone.
For each a in assignee()
For each b in Status()
For each c in Dept()
For each d in other()
.filter = "assinnee=" & a & "AND Status=" & b & "And dept=" & c
msgbox .recordcount
Next
Next
Next
Next
Hello stackexchange community.
I've built a simple tables converter, the main function of which is to convert the table from
1a Value
1b Value
1c Value
1d Value
to
a b c d
1 Value Value Value Value
Unfortunately, the macro runs pretty slow (~ 3 lines per second for one column).
I'd really appreciate if someone could take a look at my piece of code and suggest the way to speed it up.
Here's the piece of code:
Dim LastFinalList As Integer: LastFinalList = Sheet1.Range("O1000").End(xlUp).Row
For Col = 16 To 19
For c = 2 To LastFinalList
searchrange = Sheet1.Range("J:L")
lookfor = Sheet1.Cells(c, 15) & Sheet1.Cells(1, Col)
CountFor = Application.VLookup(lookfor, searchrange, 3, False)
If IsError(CountFor) Then
Sheet1.Cells(c, Col).Value = "0"
Else
Sheet1.Cells(c, Col).Value = CountFor
End If
Next c
Next Col
Thanks in advance and best regards!
UPD:
The Data in unconverted table looks like this (e.g):
Updated by Macro
Value Number Type Key Count Average Value
10 1 a 1a 2 20
30 1 a 1a 2 20
40 1 b 1b 1 40
50 1 c 1c 1 50
So it is also required to calculate averages of repeating types, create a unique list of Numbers (which is LastFinalList in my case) and finally convert it to this:
Number a b c
1 20 40 50
application.vlookupseraches by Number&Type Key, which is also assigned in the unconverted table by macro. The same time those Keys are counted, in order to calculate average for the repeating ones.
Everything works in a blink of an eye till it comes to 'to update final table part.
Full Code:
Sub ConvertToTable()
Dim LastMeter As Integer: LastMeter = Sheet1.Range("I1000").End(xlUp).Row
Sheet1.Range(Cells(2, 9), Cells(LastMeter, 9)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet1.Range("O2"), Unique:=True
Sheet1.Range("O1").Value = "The List"
Sheet1.Range("O2").Delete Shift:=xlUp
' to assign keys
For i = 2 To LastMeter
Set CountOpt = Sheet1.Cells(i, 10)
Sheet1.Cells(i, 10).FormulaR1C1 = "=r[0]c[-1]&r[0]c[-2]"
Sheet1.Cells(i, 11).FormulaR1C1 = "=COUNTIF(c10:c10, r[0]c10)"
Next i
'to calculate averages
For x = 2 To LastMeter
If Sheet1.Cells(x, 11).Value = 1 Then
Sheet1.Cells(x, 12).FormulaR1C1 = "=rc7"
ElseIf Sheet1.Cells(x, 11).Value > 1 Then
If Sheet1.Cells(x, 10).Value <> Sheet1.Cells(x - 1, 10).Value Then
Sheet1.Cells(x, 12).FormulaR1C1 = "=ROUND((SUM(rc7:r[" & Sheet1.Cells(x, 11).Value - 1 & "]c7)/" & Sheet1.Cells(x, 11).Value & "),4)"
Else
Sheet1.Cells(x, 12).FormulaR1C1 = "=r[-1]c12"
End If
End If
Next x
'to update final table
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LastFinalList As Integer: LastFinalList = Sheet1.Cells(Rows.Count, 15).End(xlUp).Row
For Col = 16 To 19
For c = 2 To LastFinalList
searchrange = Sheet1.Range("J:L")
lookfor = Sheet1.Cells(c, 15) & Sheet1.Cells(1, Col)
CountFor = Application.VLookup(lookfor, searchrange, 3, False)
If IsError(CountFor) Then
Sheet1.Cells(c, Col).Value = "0"
Else
Sheet1.Cells(c, Col).Value = CountFor
End If
Next c
Next Col
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheet1.Range("O1").Select
End Sub
Also, initially i had a SUMIF formula instead of application.vlookup to be input in each cell in the converted table. But the code was working as slow as now an was bit bulky, that's why i've decide to switch to VLOOKUP.
The thing is, if it actually the way application.vlookup works (with 0.3sec delay for each row), then i guess there's nothing that can be done, and i'm ok to accept that. Although, if that's not the case, i'd really appreciate if someone could help me out and speed up the process.
Thanks!
You can redefine your LastFinalList variable something like
LastFinalList = Sheets("Sheet1").UsedRange.Rows.Count
OR
LastFinalList = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
instead of explicitly defining used range.
Also use following line of code before your code
Application.ScreenUpdating = False
(Turn screen updating off to speed up macro code. User won't be able to see what the macro is doing, but it will run faster.)
After the whole code runs you can(optional) turn screen updating on with
Application.ScreenUpdating = True
It appears that application.vlookup in my particular case was indeed working very slow (no idea why, though). I've managed to improve macro by replacing vlookup with SUMIF formula in each cell, so now the converted table is updated instantly. Thanks everyone who participated and provided their suggestions!
I have an Excel sheet which has 200 columns. Now number of rows are 3500. So i have to search a string if it presents within any column for each row. Now to make the process fatser,I am looking for any alternate instead of Looping technique. Is there any such?
IntRow6 = 2
DataCount = 0
Do While objSheet6.Cells(IntRow6,1).Value <> ""
For DataCount = 0 to UBound(VMHArray)
IntClmn3 = 1
Do While 1 = 1
If objSheet6.Cells(IntRow6,IntClmn3).Value = VMHArray(DataCount) Then
objSheet6.Cells(IntRow6,IntClmn3+2).Value=objSheet6.Cells(IntRow6,IntClmn3+5).Value
Exit Do
End If
IntClmn3 = IntClmn3 + 1
Loop
Next
IntRow6 = IntRow6 + 1
Loop
The above is taking to much time, thus i am looking for an equivalent VBScript code which can run more faster search.
EDIT:
ParentColmnCount=ParentColmnCount-1
IntRow6=2
DataCount=0
Do While objSheet6.Cells(IntRow6,1).Value <> ""
For DataCount=0 to UBound(VMHArray)
If objSheet6.Range(objSheet6.Cells(IntRow6,1),objSheet6.Cells(IntRow6,ParentColmnCount)).Find(VMHArray(DataCount)) <> Nothing Then
MsgBox("Hi")
End If
Next
IntRow6=IntRow6+1
Loop
I'm getting any error saying that, "Object variable not set" error at the Range line of the above code.
UPDATE
I have updated my code as per your suggestion,and modified the declaration of variables as below:
Option Explicit
Dim objExcel1,objWorkbook
Dim strPathExcel1
Dim objSheet6,objSheet3
Dim IntRow6,IntRow3
Dim IntClmn3
Dim DataCount,ParentColmnCount
Dim Falg
Dim TaskCounter
Dim r As Range
Dim s As Variant
But I am getting the error again: Expected end of statement" in the line "Dim r As Range"
Check out Range.Find (which returns a Range object). It's faster than a loop.
Example:
Sub Test()
Dim r As Range
Dim matched As Range
'Get the second row
Set r = Sheet1.Range("2:2")
Set matched = r.Find("myString")
'Do stuff with matched
End Sub
UDPATE:
Assuming you are using CreateObject("Excel.Application"), then the Range object will be present (as CreateObject will return an instance of Excel which contains Range objects and functionality).
For further proof, you're already looping through the worksheet using Range objects (Cells is a Range object).
UPDATE:
Here's a more advanced example. Assume the following data in on Sheet1:
fred ethel ricky bobby 1 2 3 4
lucy myrtle fonzy rickie 1 2 3 4
joanie chachie donna patty 1 2 3 4
selma homer lisa bart 1 2 3 4
You can loop through the ranges like so:
Sub test()
Dim r As Range
Dim names(3) As String
Dim s As Variant
names(0) = "ethel"
names(1) = "fonzy"
names(2) = "patty"
names(3) = "selma"
For Each s In names
For Each r In Sheet1.Cells.CurrentRegion.Find(s)
r.Offset(0, 4).Value = r.Offset(0, 4).Value + 1000
Next r
Next s
End Sub
After the routine is done, the data is now:
fred ethel ricky bobby 1 1002 3 4
lucy myrtle fonzy rickie 1 2 1003 4
joanie chachie donna patty 1 2 3 1004
selma homer lisa bart 1001 2 3 4
UPDATE:
I just saw your comment on your question (and edited your question to include the updated code).
You're getting "Object variable not set" on that line because you cannot use <> comparisons with objects. Change the line to read:
If Not objSheet6.Range(objSheet6.Cells(IntRow6,1),objSheet6.Cells(IntRow6,ParentColmnCount)).Find(VMHArray(DataCount)) Is Nothing Then