Excel зависает после попытки манипулирования данными (VBA)

Question

Я написал простой вложенный цикл цикла в VBA, который перебирает записи на моем листе и, если он находит некоторые значения на основе условий, копирует значение в текущем листе ,

Значения NumRows и NumRowSTGSales составляют 4000 и 8000 соответственно. Когда я запускаю код, Excel просто зависает

Dim curRowNo As Long 
curRowNo = 2 
NumRowSTGSales = Worksheets("Worksheet1").UsedRange.Rows.Count 
' Set numrows = number of rows of data. 
NumRows = Worksheets("Worksheet2").UsedRange.Rows.Count 
' Select cell a1. 

' Looping through GL accounts 

'Looping through items in GL accounts 
For y = 2 To NumRows 
    'Looping through customer code found in sales data 
    For z = 2 To NumRowSTGSales 
     dataGL = Worksheets("Worksheet1").Cells(y, "A").Value 
     dataItem = Worksheets("Worksheet1").Cells(y, "B").Value 
     itemSales = Worksheets("Worksheet2").Cells(z, "F").Value 
     If dataItem = itemSales Then 
      dataCustomer = Worksheets("Worksheet2").Cells(z, "E").Value 
      Worksheets("CurrentWorksheet").Cells(curRowNo, "A").Value = dataGL 
      Worksheets("CurrentWorksheet").Cells(curRowNo, "B").Value = dataItem 
      Worksheets("CurrentWorksheet").Cells(curRowNo, "C").Value = dataCustomer 
      curRowNo = curRowNo + 1 
     End If 
    Next z 
Next y 

Answer 1

Следующий код с помощью ВПР функция ускоряет процесс много. Я тестировал его, но не знаю точно, какие типы данных хранятся в листах Excel. Можете ли вы загрузить снимок экрана из заголовков и 1-2 строки данных на рабочий лист, чтобы понять, какие типы данных у вас есть, а также структура таблиц записей.

Во всяком случае, здесь есть кусок кода, который я получил:

Sub Compare_Large_Setup() 


    Dim curRowNo       As Long 

    curRowNo = 2 

    NumRowSTGSales = Worksheets("Worksheet1").UsedRange.Rows.count 
    ' Set numrows = number of rows of data. 
    NumRows = Worksheets("Worksheet2").UsedRange.Rows.count 

    Dim VlookupRange      As Range 
    Dim result        As Variant 

    ' set Range of VLookup at Worksheet2 
    Set VlookupRange = Worksheets("Worksheet2").Range("F2:F" & NumRows) 

    'Looping through items in GL accounts 
    For y = 2 To NumRowSTGSales 
     On Error Resume Next 
     result = Application.WorksheetFunction.VLookup(Worksheets("Worksheet1").Cells(y, "B"), VlookupRange, 1, False) 

     ' no match was found with VLlookup >> advance 1 in NEXT loop 
     If Err.Number = 1004 Then 
      GoTo ExitFor: 
     End If 

     ' successful match found with VLookup function >> copy the records to "CurrentWorksheet" sheet 
     Worksheets("CurrentWorksheet").Cells(curRowNo, "A").Value = Worksheets("Worksheet1").Cells(y, "A").Value 
     Worksheets("CurrentWorksheet").Cells(curRowNo, "B").Value = result 
     Worksheets("CurrentWorksheet").Cells(curRowNo, "C").Value = Application.WorksheetFunction.VLookup(Worksheets("Worksheet1").Cells(y, "B"), VlookupRange, 4, False) 
     curRowNo = curRowNo + 1 

ExitFor: 
    Next y 


End Sub 

Answer 2

Вы пропустили кавычку в одной из строк. Одно быстрое решение, но, вероятно, не решение проблемы заключается в добавлении «DoEvents» в циклы, чтобы он не зависал.

Dim curRowNo As Long 
curRowNo = 2 
NumRowSTGSales = Worksheets("Worksheet1").UsedRange.Rows.Count 
' Set numrows = number of rows of data. 
NumRows = Worksheets("Worksheet2").UsedRange.Rows.Count 
' Select cell a1. 

' Looping through GL accounts 

'Looping through items in GL accounts 
For y = 2 To NumRows 
    'Looping through customer code found in sales data 
    For Z = 2 To NumRowSTGSales 
     dataGL = Worksheets("Worksheet1").cells(y, "A").Value 
     dataItem = Worksheets("Worksheet1").cells(y, "B").Value 
     itemSales = Worksheets("Worksheet2").cells(Z, "F").Value 
     If dataItem = itemSales Then 
      dataCustomer = Worksheets("Worksheet2").cells(Z, "E").Value 
      Worksheets("CurrentWorksheet").cells(curRowNo, "A").Value = dataGL 
      Worksheets("CurrentWorksheet").cells(curRowNo, "B").Value = dataItem 
      Worksheets("CurrentWorksheet").cells(curRowNo, "C").Value = dataCustomer 
      curRowNo = curRowNo + 1 
     End If 
    DoEvents 
    Next Z 
DoEvents 
Next y 

Answer 3

Спасибо всем за ваши полезные ответы, окончательный подход я использовал, чтобы решить эту проблему, чтобы добавить сводную таблицу данных, я хотел чтобы пройти, я затем динамически добавлял фильтр в сводную таблицу для этого конкретного элемента вместо того, чтобы перебирать через 1000 записей через код.

Затем я взял каждого соответствующего клиента через сводную таблицу.

Пример кода для того же показано ниже:

Dim itemCustSalesWS As Worksheet 
     Set itemCustSalesWS = ActiveWorkbook.Worksheets("Sales item customer pivot") 
     Dim itemCustSalesPivot As PivotTable 
     Set itemCustSalesPivot = itemCustSalesWS.PivotTables("Item Customer Pivot sales") 
     itemCustSalesPivot.PivotFields("Item_Code").Orientation = xlPageField 
     'Filtering here 
     Dim pf As PivotField 
     Set pf = Worksheets("Sales item customer pivot").PivotTables("Item Customer Pivot sales").PivotFields("Item_Code") 
     With pf 
     .ClearAllFilters 
     .CurrentPage = dataItem 
     End With 

     With itemCustSalesWS.UsedRange 
     itemCustfirstrow = .Row 
     itemCustfirstcol = .Column 
     itemCustlastrow = .Rows(UBound(.Value)).Row 
     itemCustlastcol = .Columns(UBound(.Value, 2)).Column 
     End With 

     'The following loop runs for the current filtered item FROM SEQUENCE 1 IN SALES ITEM CUSTOMER PIVOT, and maps 
     'their amount in front of the GL accounts and items 
     For z = 4 To itemCustlastrow - 1 

     'Logic for calculation of Sequence 4 goes here 
     dataCustomer = Worksheets("Sales item customer pivot").Cells(z, "A").Value 
     sumItemCust = Worksheets("Sales item customer pivot").Cells(z, "B").Value 

     Worksheets("Item customer mapping").Cells(curRowNo, "A").Value = dataGL 
     Worksheets("Item customer mapping").Cells(curRowNo, "B").Value = dataItem 
     Worksheets("Item customer mapping").Cells(curRowNo, "C").Value = dataCustomer 
     Worksheets("Item customer mapping").Cells(curRowNo, "D").Value = seq1Amount 
     Worksheets("Item customer mapping").Cells(curRowNo, "E").Value = volumePerItem 
     Worksheets("Item customer mapping").Cells(curRowNo, "F").Value = sumItemCust 

Спасибо всем за помощь и быстрой реакции.