这是在EXCEL中按某一列求同类项合并的程序,当有100多条记录求时,执行起来特别慢,求大虾优化Private Sub CommandButton1_Click()
rangename1 = TextBox1.Text
qq = Val(TextBox2.Text)
startrange1 = qq + 1
endrange1 = Val(TextBox3.Text)
rangename2 = TextBox1.Text
startrange2 = Val(TextBox2.Text)
endrange2 = Val(TextBox3.Text)
For a = startrange2 To endrange2
c$ = a
row2 = Chr(Asc(rangename2) + 1)
row3 = Chr(Asc(rangename2) + 2)
row4 = Chr(Asc(rangename2) + 3)
row5 = Chr(Asc(rangename2) + 4)
row6 = Chr(Asc(rangename2) + 5)
row7 = Chr(Asc(rangename2) + 6)
row8 = Chr(Asc(rangename2) + 7)
aaa: For d = startrange1 To endrange1
r$ = d
range1 = Chr(Asc(rangename1) + 0)
range2 = Chr(Asc(rangename1) + 1)
range3 = Chr(Asc(rangename1) + 2)
range4 = Chr(Asc(rangename1) + 3)
range5 = Chr(Asc(rangename1) + 4)
range6 = Chr(Asc(rangename1) + 5)
range7 = Chr(Asc(rangename1) + 6)
range8 = Chr(Asc(rangename1) + 7)
Range(rangename2 + c$).Select
qs = ActiveCell.Value
Range(rangename1 + r$).Select
xh = ActiveCell.Value
If qs = xh Then
Range(row4 + c$).Select
sl2 = ActiveCell.Value
Range(range4 + r$).Select
sl1 = ActiveCell.Value
sl = sl1 + sl2
Range(range2 + r$ + ":" + range8 + r$).Select
Selection.EntireRow.Delete
endrange2 = endrange2 - 1
endrange1 = endrange1 - 1
Range(row4 + c$).Select
ActiveCell.FormulaR1C1 = sl
If startrange1 < endrange1 Then GoTo aaa Exit For
End If
Next d
startrange1 = startrange1 + 1
Next a
End Sub
rangename1 = TextBox1.Text
qq = Val(TextBox2.Text)
startrange1 = qq + 1
endrange1 = Val(TextBox3.Text)
rangename2 = TextBox1.Text
startrange2 = Val(TextBox2.Text)
endrange2 = Val(TextBox3.Text)
For a = startrange2 To endrange2
c$ = a
row2 = Chr(Asc(rangename2) + 1)
row3 = Chr(Asc(rangename2) + 2)
row4 = Chr(Asc(rangename2) + 3)
row5 = Chr(Asc(rangename2) + 4)
row6 = Chr(Asc(rangename2) + 5)
row7 = Chr(Asc(rangename2) + 6)
row8 = Chr(Asc(rangename2) + 7)
aaa: For d = startrange1 To endrange1
r$ = d
range1 = Chr(Asc(rangename1) + 0)
range2 = Chr(Asc(rangename1) + 1)
range3 = Chr(Asc(rangename1) + 2)
range4 = Chr(Asc(rangename1) + 3)
range5 = Chr(Asc(rangename1) + 4)
range6 = Chr(Asc(rangename1) + 5)
range7 = Chr(Asc(rangename1) + 6)
range8 = Chr(Asc(rangename1) + 7)
Range(rangename2 + c$).Select
qs = ActiveCell.Value
Range(rangename1 + r$).Select
xh = ActiveCell.Value
If qs = xh Then
Range(row4 + c$).Select
sl2 = ActiveCell.Value
Range(range4 + r$).Select
sl1 = ActiveCell.Value
sl = sl1 + sl2
Range(range2 + r$ + ":" + range8 + r$).Select
Selection.EntireRow.Delete
endrange2 = endrange2 - 1
endrange1 = endrange1 - 1
Range(row4 + c$).Select
ActiveCell.FormulaR1C1 = sl
If startrange1 < endrange1 Then GoTo aaa Exit For
End If
Next d
startrange1 = startrange1 + 1
Next a
End Sub
Dim objRangeValue As Variant
With objOpSheet
Set objDateRange = .Range(.Cells(Target.Row + 2, 2), .Cells(Target.Row + 32, 25))
objDateRange.ClearContents
'将要修改的数据区读入内存,要写回去的时候反过来就好了
objRangeValue = objDateRange.Value
End With