Selasa, 09 Desember 2014

Re: [ExcelVBA] Re: Help required for a difficult macro

 

Dear All 

I have received following code but the problem is that i run these code more than 5000 rows, excel is hanged and going to not responding.

Sub Data_base()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng2 As Range
Dim LRws1 As Long, LRws3 As Long
Dim chk As Variant
Dim match_formula As Variant

Set ws1 = Sheets("Fruit Data Base")
Set ws2 = Sheets("Fruit Order List")

Application.ScreenUpdating = False

ws1.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "Helper_sheet"
     
Set ws3 = Sheets("Helper_sheet")

On Error Resume Next
LRws2 = ws2.UsedRange.Rows.Count
LRws3 = ws3.UsedRange.Rows.Count

Set rng2 = ws2.Range("D3:D" & LRws2)


For Each r In rng2
    If r.Offset(, -1).Value = 0 Or r.Offset(, -1).Value = "-" Then
        r.Value = "!"
        For i = 1 To LRws3
            If ws3.Range("A1").Offset(i).Value = r.Offset(, -2).Value And ws3.Range("A1").Offset(i, 3).Value = r.Offset(, 1).Value Then
            r.Value = ws3.Range("A1").Offset(i, 2).Value
            ws3.Range("A1").Offset(i, 2).EntireRow.Delete
            GoTo Skip1
            End If
        Next i
      End If
Skip1:
Next r

LRws3 = ws3.UsedRange.Rows.Count

For Each r In rng2
    If r.Value = "!" Then
        For i = 1 To LRws3
            If ws3.Range("A1").Offset(i).Value = r.Offset(, -2).Value And ws3.Range("A1").Offset(i, 3).Value > r.Offset(, 1).Value Then
            ws3.Range("A1").Offset(i, 4).Value = ws3.Range("A1").Offset(i, 3).Value - r.Offset(, 1).Value
            End If
        Next i
     
        For i = 1 To LRws3
            If WorksheetFunction.Max(ws3.Range("A1:A" & LRws3).Offset(, 4)) > 0 And ws3.Range("A1").Offset(i, 4).Value = WorksheetFunction.Min(ws3.Range("A1:A" & LRws3).Offset(, 4)) Then
                r.Value = ws3.Range("A1").Offset(i, 2).Value
                ws3.Range("A1").Offset(i, 3).Value = ws3.Range("A1").Offset(i, 4).Value
                ws3.Range("A1:A" & LRws3).Offset(, 4).ClearContents
                GoTo skip2
            End If
        Next i
    End If
skip2:
    
Next r

Application.DisplayAlerts = False
ws3.Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub



On Monday, December 8, 2014 1:55 AM, ayaz khan <ayazthegreat2001@yahoo.com> wrote:


Further I explain it here again
There are 2 sheets one is sheet1 and another  is result sheet
Sheet1 is a product database
Result sheet is a query or order sheet of product
By matching ID from result sheet to sheet1, You have to distribute EDI # from sheet1 to result sheet in col c on following conditions
1-  where col b is blank or - or 0 value in result sheet
2 _ if above condition is met then distribute order (EDI # from sheet1 col b as to result sheet) as  I mentioned in my test file in result sheet and check qty in sheet1 if order product qty less or equal
In less qty it goes to next matching ID qty if it is equal or greater then copy this EDI  # from sheet1 col b to result sheet in col c
I have given example in my sent file in result sheet please go through it carefully
3 - if first matching qty v b p
Sent from Yahoo Mail on Android
From:"ayaz khan" <ayazthegreat2001@yahoo.com>
Date:Mon, 8 Dec, 2014 at 1:28 AM
Subject:Re: [ExcelVBA] Re: Help required for a difficult macro

Thanks David for your advice I explain my logic in my sent file as well you can see it if you have any confusion or query regarding to my sent file in required result in result sheet please do mention it and I must explain it clearly
From:"'david braithwaite' dbraithwaite@charter.net [ExcelVBA]" <ExcelVBA@yahoogroups.com>
Date:Mon, 8 Dec, 2014 at 1:14 AM
Subject:[ExcelVBA] Re: Help required for a difficult macro

 
Hi
Suggest that you write the logic required as if you were giving directions to another person who was going to do the process by hand.
Excel is just a tool for implementing such a process, but so is a pencil and paper.  Write for the latter and get surprised by the elegant solution for the former.
Tim Lewis's posting MAY be such a solution.
 
-db-
 


__._,_.___

Posted by: ayaz khan <ayazthegreat2001@yahoo.com>
Reply via web post Reply to sender Reply to group Start a New Topic Messages in this topic (21)
----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

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

.

__,_._,___

Tidak ada komentar:

Poskan Komentar