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
嘿伙计们，上面的代码是我一直致力于重要的一些数据，从sheet2到sheet1。表2包含第1列中的项目ID编号，第2列中的术语（奖励日期），第3列中的奖励类型以及第5列中的金额。表1在第1列中具有项目ID，在第4列中具有术语（输入日期）。第2页有学期给出的奖项，并由项目ID索引，我想重要的数据，并将它们放在文本中间的if instr语句给出的列中。
此代码的目标是遍历工作表1，A列中的项目ID编号，并检查它们是否存在于工作表2列A中，然后导入奖励类型和数量，按年份差异排序在表1的输入日期和表2上的奖励日期之间。日期有春/秋和一年，所以我尝试了左（字符串，＃）命令只有几年减去，然后上述的块如果instr代码应该平衡学期的差异。
表2中有相同项目ID的倍数，因此我需要代码在表2上的上一行之后恢复循环，直到表1上的每个项目ID都被交叉引用。
有人可以在我的代码中指出错误吗？单击命令按钮时没有任何反应。
问题出现在第一个if语句中，当我知道至少有450个数据匹配时，它会跳过所有需要满足条件的操作。
刚编辑了我的代码，它现在仍在运行。
评论列表感谢评论：修复逻辑陈述问题，固定范围/单元格/单元格问题，固定循环问题，固定的右/左字符串问题
答案 0 :(得分：1)
我可以建议您按如下方式重构代码：
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
我不确定Exit For行。您的问题意味着您需要处理Sheet2中的多个条目（如果存在）。如果是这样，删除Exit For行，但这将增加运行时，因为它需要迭代Sheet1中Sheet1中每行的所有3421行。
编辑：BruceWayne建议的对ScreenUpdating和Calculation的更改。
答案 1 :(得分：0)
感谢您提供所有帮助，以下代码适用于任何人遇到类似问题时遇到此问题。
此代码循环使用整数i的sheet1和整数q的sheet2，以在两个工作表的第一个/ A列中找到匹配项。由于我在A列的sheet2上有多个项目构思（工作表1列A），它在找到sheet2上找到的行（q）后继续。然后，这继续通过指定的行数（i），其次继续通过每个i的所有行（q）。
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