VBA循环无法正常运行

Question

Sub Button2_Click()
Dim i As Integer, q As Integer
i = 2
q = 2
Do While i < 468 And q < 3450
If Worksheets("Sheet1").Range("A" & i).Value = Worksheets("Sheet2").Range("A" & q).Value Then
    If Len(Worksheets("Sheet1").Cells(i, 4)) < 12 Then
        Dim edate As String, adate As String, ed As String, ad As String, n As Integer, x As Integer, y As Integer
        edate = Sheets("sheet1").Cells(i, 4).Value
        adate = Sheets("sheet2").Cells(q, 2).Value
        ed = Right(Sheets("sheet1").Cells(i, 4), 4)
        ad = Right(Sheets("sheet2").Cells(q, 2), 4)
        n = CInt(ad) - CInt(ed)
        If InStr(edate, "Fall") And InStr(adate, "Fall") Then x = 7 + (5 * n)
        If InStr(edate, "Fall") And InStr(adate, "Spring") Then x = 9 + (5 * (n - 1))
        If InStr(edate, "Spring") And InStr(adate, "Spring") Then x = 9 + (5 * n)
        If InStr(edate, "Spring") And InStr(adate, "Fall") Then x = 12 + (5 * n)
        y = x - 1
        Worksheets("Sheet1").Cells(i, x).Value = Worksheets("Sheet2").Cells(q, 5).Value
        Worksheets("Sheet1").Cells(i, y).Value = Worksheets("Sheet2").Cells(q, 3).Value
        i= i +1
        q=2
    Else
        i = i + 1
        q = 2
    End If
Else
    If q < 3423 Then
        q = q + 1
    else
        i = 1 + 1
        q=2
    End If
    Else
        i = i + 1
        q = 2
    End If
End If
Loop
End Sub

Hey guys, the code above is something I've been working on to important some data from sheet2 to sheet1. Sheet 2 has project Id numbers in column 1, terms (awarddate) in column 2, type of award in column 3, and amount in column 5. Sheet 1 has project id in column 1, and term (entry date) in column 4. Sheet 2 has awards given by semester and indexed by project id, I would like to important the data and place them into the columns given by the if instr statements int he middle of the text.

The goal of this code is to loop through the project id numbers in sheet 1, column A and check to see if they exist in sheet 2 column A, and then to import the award type and amount sorted by the difference in years between the entry date on sheet 1 and the award date on sheet 2. The dates have spring/fall and a year, so I tried the left(string, #) command to only have years to subtract, and then the block of aforementioned if instr code is supposed to balance out the difference in semesters.

There are multiples of the same project id in sheet 2, so I need the code to resume the loop after the previous row on sheet 2, until every project id on sheet 1 has been cross-referenced.

Can someone point out the error in my code? Nothing happens when I click the command button.

The problem is in the first if statement, it skips all of the operations that require the condition to be met, when I know that at least 450 of the data match.

Just edited my code, it's still running right now.

List of edits thanks to comments: fixed logical statment issue, fixed range/cell/cells issue, fixed looping issue, fixed right/left string issue

Answer 1

Can I suggest that you refactor your code as follows:

Sub Button2_Click()
    Dim i As Integer, q As Integer
    'Storing the ids in an array will make it much faster to access instead
    'of interfacing with Excel's object model a couple of million times
    Dim ids1, ids2
    Dim origCalcMode As XlCalculation

    'Switch off ScreenUpdating to improve speed
    Application.ScreenUpdating = False
    'Switch off auto calculation to improve speed
    origCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual

    ids1 = Application.Transpose(Worksheets("Sheet1").Range("A2:A467").Value)
    ids2 = Application.Transpose(Worksheets("Sheet2").Range("A2:A3422").Value)
    'Using For loops rather than manually keeping track of row counters
    'makes the code MUCH cleaner and less prone to errors
    For i = 2 To 467
        'Moving this test to earlier in the code avoids having to iterate
        'through all the rows on Sheet2 when there is nothing that can be
        'done with the matching data anyway
        If Len(Worksheets("Sheet1").Cells(i, 4)) < 12 Then
            For q = 2 To 3422
                If ids1(i - 1) = ids2(q - 1) Then
                    Dim edate As String, adate As String, ed As String, ad As String, n As Integer, x As Integer, y As Integer
                    edate = Sheets("sheet1").Cells(i, 4).Value
                    adate = Sheets("sheet2").Cells(q, 2).Value
                    ed = Right(Sheets("sheet1").Cells(i, 4), 4)
                    ad = Right(Sheets("sheet2").Cells(q, 2), 4)
                    n = CInt(ad) - CInt(ed)
                    If InStr(edate, "Fall") And InStr(adate, "Fall") Then x = 7 + (5 * n)
                    If InStr(edate, "Fall") And InStr(adate, "Spring") Then x = 9 + (5 * (n - 1))
                    If InStr(edate, "Spring") And InStr(adate, "Spring") Then x = 9 + (5 * n)
                    If InStr(edate, "Spring") And InStr(adate, "Fall") Then x = 12 + (5 * n)
                    y = x - 1
                    Worksheets("Sheet1").Cells(i, x).Value = Worksheets("Sheet2").Cells(q, 5).Value
                    Worksheets("Sheet1").Cells(i, y).Value = Worksheets("Sheet2").Cells(q, 3).Value
                    Exit For
                End If
            Next
        End If
    Next

    'Restore application settings
    Application.ScreenUpdating = True
    Application.Calculation = origCalcMode
End Sub

I'm not sure about the Exit For line. Your question implies that you need to process multiple entries from Sheet2 if they exist. If so, delete the Exit For line, but that will increase the runtime because it will need to iterate over all 3421 rows in Sheet2 for each row in Sheet1.

Edit: Included changes to ScreenUpdating and Calculation as suggested by BruceWayne.

Answer 2

Thanks for all of the help, here is the code that works in case anyone stumbles upon this with a similar problem.

This code loops through sheet1 with integer i and sheet2 with integer q to find a match in the first/A column of both sheets. As I have multiples of the project ideas (Sheet 1 column A) on sheet2 in column A, it continues after finding a match at the row (q) found on sheet2. This then continues through the specified amount of rows (i) and secondly through all rows (q) for each i.

Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

End Sub

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True

End Sub


Sub Button2_Click()
Dim i As Integer, q As Integer, origCalcMode As XlCalculation
i = 3
q = 2
Call OptimizeCode_Begin
Do While i < 467
If Len(Worksheets("Sheet1").Cells(i, 4)) < 12 Then
    If Worksheets("Sheet1").Cells(i, 1).Value = Worksheets("Sheet2").Cells(q, 1).Value Then
        Dim edate As String, adate As String, ed As String, ad As String, n As Integer, x As Integer, y As Integer
        edate = Sheets("sheet1").Cells(i, 4).Value
        adate = Sheets("sheet2").Cells(q, 2).Value
        ed = Right(Sheets("sheet1").Cells(i, 4), 4)
        ad = Right(Sheets("sheet2").Cells(q, 2), 4)
        n = CInt(ad) - CInt(ed)
        If InStr(edate, "Fall") And InStr(adate, "Fall") Then x = 7 + (5 * n)
        If InStr(edate, "Fall") And InStr(adate, "Spring") Then x = 9 + (5 * (n - 1))
        If InStr(edate, "Spring") And InStr(adate, "Spring") Then x = 9 + (5 * n)
        If InStr(edate, "Spring") And InStr(adate, "Fall") Then x = 12 + (5 * n)
        y = x - 1
        Worksheets("Sheet1").Cells(i, x).Value = Worksheets("Sheet2").Cells(q, 5).Value
        Worksheets("Sheet1").Cells(i, y).Value = Worksheets("Sheet2").Cells(q, 3).Value
        q = q + 1
    Else
        If q < 1236 Then
            q = q + 1
        Else
            i = i + 1
            q = 2
        End If
    End If
Else
   i = i + 1
   q = 2
End If
Loop
Call OptimizeCode_End
End Sub