• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need a fix to enable this marco in my existing workbook

kuldeepjainesl

kuldeepjainesl

Member
Hi Experts,


My macro is taking considerable time to execute so I thought to have some progress indication on excel. I searched and land on excelvbamacros website for what i wanted.


Now the problem is how I can use this code in my existing codes so that when I press button to execute my macro, this also run showing progress.


In short i want to modified this macro to call another macro in it.


Both the codes are in next comments:
 
I need a modified version of this code which can call a macro in it.

--------------------------------------------------------------------------------
Sub example_1()
Dim rng As Range, i As Long, clnrng As Range

Set clnrng = Range("a1:a10000")
i = 0
With Prog_bar
'SET MIN value to 0
.ProgressBar1.Min = 0
'SET Max value equal to cells count
.ProgressBar1.Max = clnrng.Cells.Count
.Show vbModeless
End With
For Each rng In clnrng.Cells
' do clean and trim using vba
rng.Value = Application.WorksheetFunction.Clean(Application.WorksheetFunction.Trim(rng.Value))
i = i + 1
'change the value of progress bar to show the progress using fill color
Prog_bar.ProgressBar1.Value = i
' chnage the caption of user form to display the percentage of task completed
Prog_bar.Caption = VBA.Format(i / Prog_bar.ProgressBar1.Max, "0%") & " Complete"
DoEvents ' DoEvents allows the UserForm to update.
Next
' task finish unload progress bar
Unload Prog_bar
End Sub
-----------------------------------------------------------------------------------
This is the macro i want to call inside above code
-----------------------------------------------------------------------------------
Public Sub Copy_supply_Data()
' Dim Customer_Name As String
' Dim Start_Date As Date
' Dim End_Date As Date
' Dim Additional_Criterion As String

' With Sheets("Dashboard")
' Customer_Name = .Range("A21").Value
' Start_Date = .Range("D21").Value
' End_Date = .Range("E21").Value
' Additional_Criterion = .Range("G21").Value
' End With
' By declaring an array , the above statements are replaced by the following two statements
' Customer_name is Record_Array(1,1)
' Start_Date is Record_Array(1,4)
' End_Date is Record_Array(1,5)
' Additional_Criterion is Record_Array(1,7)

Application.ScreenUpdating = False

Dim Copy_From_Sheet As Worksheet
Dim Paste_To_Sheet As Worksheet

Dim Row_Array As Variant

Dim Record_Array As Variant
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value

Set Copy_From_Sheet = ThisWorkbook.Worksheets("Supply Data")
Set Paste_To_Sheet = ThisWorkbook.Worksheets("supply filtered data")

Paste_To_Sheet.Activate

Application.ScreenUpdating = True
user_input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If user_input = vbYes Then
ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Select
Else
ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)).EntireRow.ClearContents
ActiveSheet.Range("A2").Select
End If
Application.ScreenUpdating = False

Copy_From_Sheet.Activate
ActiveSheet.Range("Supply_Data").Select
Number_of_rows = Selection.Rows.Count
Number_of_columns = Selection.Columns.Count

row_counter = 0
For I = 1 To Number_of_rows
Row_Array = Selection.Cells(1, 1).Offset(I - 1, 0).Resize(1, Number_of_columns).Value
Customer_Name = Row_Array(1, 1)
Check_Date = Row_Array(1, 9)
Additional_Check = Row_Array(1, 11)

If Customer_Name = Record_Array(1, 1) Then
If ((Check_Date >= Record_Array(1, 4)) And (Check_Date <= Record_Array(1, 5))) Then
If ((Record_Array(1, 7) = "") Or (Additional_Check = Record_Array(1, 7))) Then
Paste_To_Sheet.Activate
ActiveCell.Offset(row_counter, 0).Resize(1, Number_of_columns).Value = Row_Array
row_counter = row_counter + 1
Copy_From_Sheet.Activate
End If
End If
End If
Next

Application.ScreenUpdating = True
If row_counter > 0 Then
MsgBox "Procedure Over , " & Str(row_counter) & " records copied / pasted"
End If

End Sub
-----------------------------------------------------------------------------------
 
Not sure about the macro you found previously, but I think this is what you want.

[pre]
Code: 
Public Sub Copy_supply_Data()
' Dim Customer_Name As String
' Dim Start_Date As Date
' Dim End_Date As Date
' Dim Additional_Criterion As String

' With Sheets("Dashboard")
'      Customer_Name = .Range("A21").Value
'      Start_Date = .Range("D21").Value
'      End_Date = .Range("E21").Value
'     Additional_Criterion = .Range("G21").Value
' End With
' By declaring an array , the above statements are replaced by the following two statements
' Customer_name is Record_Array(1,1)
' Start_Date is Record_Array(1,4)
' End_Date is Record_Array(1,5)
' Additional_Criterion is Record_Array(1,7)

Application.ScreenUpdating = False

Dim Copy_From_Sheet As Worksheet
Dim Paste_To_Sheet As Worksheet

Dim Row_Array As Variant

Dim Record_Array As Variant
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value

Set Copy_From_Sheet = ThisWorkbook.Worksheets("Supply Data")
Set Paste_To_Sheet = ThisWorkbook.Worksheets("supply filtered data")

Paste_To_Sheet.Activate

Application.ScreenUpdating = True
user_input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If user_input = vbYes Then
ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Offset(1, 0).Select
Else
ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)).EntireRow.ClearContents
ActiveSheet.Range("A2").Select
End If
Application.ScreenUpdating = False

Copy_From_Sheet.Activate
ActiveSheet.Range("Supply_Data").Select
number_of_rows = Selection.Rows.Count
Number_of_columns = Selection.Columns.Count

row_counter = 0
For i = 1 To number_of_rows
'This is where we begin our loop
'Choose what type of status you would like to see
Application.StatusBar = i & " of " & number_of_rows & " complete" ' does a "x of y complete"
Application.StatusBar = Format(i / number_of_rows, "0%") 'gives percent complete

Row_Array = Selection.Cells(1, 1).Offset(i - 1, 0).Resize(1, Number_of_columns).Value
Customer_Name = Row_Array(1, 1)
Check_Date = Row_Array(1, 9)
Additional_Check = Row_Array(1, 11)

If Customer_Name = Record_Array(1, 1) Then
If ((Check_Date >= Record_Array(1, 4)) And (Check_Date <= Record_Array(1, 5))) Then
If ((Record_Array(1, 7) = "") Or (Additional_Check = Record_Array(1, 7))) Then
Paste_To_Sheet.Activate
ActiveCell.Offset(row_counter, 0).Resize(1, Number_of_columns).Value = Row_Array
row_counter = row_counter + 1
Copy_From_Sheet.Activate
End If
End If
End If
Next

'Return control of the status bar to XL
Application.StatusBar = False

Application.ScreenUpdating = True
If row_counter > 0 Then
MsgBox "Procedure Over , " & Str(row_counter) & " records copied / pasted"
End If

End Sub
[/pre]
 
Thanks Luke,


This is the basic requirement I was looking at, To make it more eye catching please suggest how I can use a user form with progress bar to show this status.


Application.StatusBar = Format(i / number_of_rows, "0%") 'gives percent complete


Regards,
 
I could do it via but this made calculation very slow. I am doing something wrong & want to figure out.


With Prog_Bar

'SET MIN value to 0

.ProgressBar1.Min = 0

'SET Max value as per your requirement

.ProgressBar1.Max = number_of_rows

.Show vbModeless

'change the value of progress bar to show the progress using fill color

.ProgressBar1.Value = i

' chnage the caption of user form to display the percentage of task completed

.Caption = i & " of " & number_of_rows & " complete"

DoEvents ' DoEvents allows the UserForm to update.

End With

' task finish unload progress bar

Unload Prog_Bar
 
Hi Luke,


Thanks,


Thanks for suggesting the way to use application status bar. I have dropped the idea of loading user interface as it is getting very slow. I will use the way you have suggested so once again a lot of Thanks for resolving my problem.


Regards,
 
I have never used them in the past. See if any of it is going to be useful for you:

http://www.andypope.info/vba/pmeter.htm
 
Hello Shrivallabha,


Really very informative. yes i was looking for something like this but all these seems to increase a calculation time drastically.


Thanks for sharing this and i will surely use these whenever i will have small set of data (Just for Fun)


Regards,
 
Hi, KPJSWT!

Give a look at this:

http://chandoo.org/forums/topic/match-strange-behaviour#post-37751

and look for user form Wait.

Regards!

PS: BTW, your nick seems as if someone stole all the vowels :)
 
Hi SirJB7,


I will see these as i get time.


-------------------------------------------PS:---------------------------------------


Yup these seems but there are not :)


These are initial of My & my Wife name. "K"uldee"P" "J"ain & "S""W"a"T"i


I keep her with me all the time. Even at work too...We work for the same Organisation.


Regards,
 
Hi SirJB7


Now don't embarrass me...I know that Mid is a function & I already did it. it will return "P"


The missing part is what the "P" represent :)


Regards,
 
By using Activate/ Select and Selection, u waste a lot of time. You can work your code without them and it'll be running faster. You are using Arrays, its a good idea.

Here code modified and I guess faster

[pre]
Code: 
Public Sub Copy_Supply_Data()
Dim LastLig As Long, Number_Of_Rows As Long, Row_Counter As Long, i As Long, Check_Date As Long
Dim Row_Array As Variant, Record_Array As Variant, Tmp() As Variant
Dim Customer_Name As String, Additional_Check As String
Dim Number_Of_Columns As Integer, j As Integer
Dim WherePaste As Range
Dim User_Input As Byte

Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Supply Data").Range("Supply_Data")
Number_Of_Rows = .Rows.Count
Record_Array = ThisWorkbook.Worksheets("Dashboard").Range("A21:G21").Value
Number_Of_Columns = .Columns.Count
Row_Array = .Value

For i = 1 To Number_Of_Rows
Application.StatusBar = Format(i / Number_Of_Rows, "0%")
Customer_Name = Row_Array(i, 1)
Check_Date = Row_Array(i, 9)
Additional_Check = Row_Array(i, 11)

If Customer_Name = Record_Array(1, 1) Then
If Check_Date >= Record_Array(1, 4) And Check_Date <= Record_Array(1, 5) Then
If Record_Array(1, 7) = "" Or Additional_Check = Record_Array(1, 7) Then
Row_Counter = Row_Counter + 1
ReDim Preserve Tmp(1 To Number_Of_Columns, 1 To Row_Counter)
For j = 1 To Number_Of_Columns
Tmp(j, Row_Counter) = Row_Array(i, j)
Next j
End If
End If
End If
Next i
End With

If Row_Counter > 0 Then
With ThisWorkbook.Worksheets("supply filtered data")
User_Input = MsgBox("Do you wish to APPEND to earlier data ( Y/N ) ; NO means earlier data will be overwritten !", vbYesNo)
If User_Input = vbYes Then
Set WherePaste = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
Else
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastLig >= 2 Then .Rows("2:" & LastLig).ClearContents
Set WherePaste = .Range("A2")
End If
End With

WherePaste.Resize(Row_Counter, Number_Of_Columns).Value = Application.Transpose(Tmp)
Set WherePaste = Nothing
MsgBox "Procedure Over , " & Row_Counter & " records copied / pasted"
Else
MsgBox "Nothing copied / pasted"
End If
Application.StatusBar = False
End Sub
[/pre]
 
Thanks for looking in the code and suggesting new code. I tried, but this failed and need to debug. I will try to look in to correct it (if I would) however the Luke code is taking 80 sec to execute in my workbook.


Two major observation


No user input from pop up for append/overwrite

Gives type mismatch error 13 at Check_Date = Row_Array(i, 9)


Regard,
 
I guess than Check_date is a date and in column 9 all datas are dates.


if Range("Supply_Data") has in first line titles, the error will be appear


Change the 2 lines in code

`'....

Row_Array = .Offset(1, 0).Resize(Number_Of_Rows - 1, Number_Of_Columns).Value 'Here


For i = 1 To Number_Of_Rows - 1 'and here

'...etc`


No user input from pop up for append/overwrite


It will be appear at the end. we should know how is your file


All this, I guess, I don't have your file


Regard
 
Hi Mercatog.


How you guys are able to make gauss that it my biggest mystery to solve. Answer to your gauss is "YES".


Let me make changes and revert back to you by tomorrow.


Regards,
 
Hi, KPJSWT!

I didn't intend to embarrass you, sorry if it looked like that. Nothing farthest.

I was referring to the explanation of your nick in the PS of this comment:

http://chandoo.org/forums/topic/need-a-fix-to-enable-this-marco-in-my-existing-workbook-6#post-38201

... and I made a typo mistake: instead of "P" I should have written "S".

It was a polite intend to widen my regards to both persons involved. I apologize for the misunderstanding.

Regards!
 
Hi SirJB7


Aah... I just could understand the intention but taken it to learn something new. After all it was a ninja comment but typo mistake lead this to different line.


Cheers
 
Hi Mercatog.


I needed to change "Check_Date As Date" along with you lines and this code run faster by 5 sec and got completed in 75 sec but let me admit that this is more structured then my existing one.


It copied 366 record from 150K records.

---------------------------------------------------------------------------------------

As we are using Application.StatusBar = Format(i / Number_Of_Rows, "0%") line & it takes control of status bar to show progress it has three problem


1) it refresh too fast while it is not required. I think it should only refresh if % value get changed

2)If i press "Esc" to stop execution of marco. it do not release the control to application.

3) in above case excel crash and need to close from CTRL+ALT+DELETE

----------------------------------------------------------------------------------------


Thanks & Regards,
 
Hi


Actually it is being copied to this sheet which is mapped for another sheet to calculate different values and like this operation there are many other sheet also so doing it manually by filter is not a good idea for me.


Regards,
 
Hi,


Strange...


I change this line Application.ScreenUpdating = False to Application.ScreenUpdating = True


and macro is running 4 time faster for same data set. As I understand that "False" property is to increase speed by not updated screen.


It took only 17 Sec to complete task which taken 80 sec with "False"


Any explanation...


Regards,
 
You must log in or register to reply here.
Back
Top