刚刚帮人写的一个用键盘上下键实现加1和减1.doc

如果排序仅仅是为了按顺序设置组合框的列表，除了工作表排序外，还可以用数组排序、ADO排序，下面是ADO法，连字典也不用了，代码较少，但速度不一定快：Private Sub UserForm_Initialize() Dim arr With CreateObject(ADODB.Connection) .Open Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source = & ThisWorkbook.FullName arr = .Execute(select distinct * from Sheet1$c:c where 工程编号 is not null order by 工程编号).GetRows End With Me.ComboBox1.List = Application.Transpose(arr)End Sub刚刚帮人写的一个用键盘上下键实现加1和减1 Sub auto_open() 加载宏Application.OnKey UP, jjApplication.OnKey DOWN, zzEnd SubSub jj()x = Selection.Rowy = Selection.ColumnIf IsNumeric(Cells(x, y) ThenCells(x, y) = Cells(x, y) + 1End IfEnd SubSub zz()x = Selection.Rowy = Selection.ColumnIf IsNumeric(Cells(x, y) ThenCells(x, y) = Cells(x, y) - 1End IfEnd Sub前面的附件代码有些没用的代码，没来得及删除，另外写入单元格次数较多，下面代码全部由数组来完成，速度快 Sub 排序()Dim d As New Dictionary, Arr, i&, j&, brr(), m&, z&Arr = Range(Cells(1, 2), Cells(Cells(Rows.Count, 1).End(3).Row, 121)ReDim brr(1 To UBound(Arr), 1 To 120)For i = 1 To 120d(Arr(1, i) = iNextm = 0md = InputBox(请输入排列起始序号, 重新排列, 1)If md = 2 Then For j = md To 120 Step md m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, d(j) Next Next For i = 1 To md - 1 For j = i To 120 Step md m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, d(j) Next Next NextElseIf md = 1 Then For i = 1 To 2 For j = i To 120 Step 2 m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, d(j) Next NextNextEnd Ifb1.Resize(UBound(brr), 120) = brrEnd Sub没想到更快的办法，有点慢。 Sub PL_Click() Dim md&, rng As Range, arr, oDict, i&, arrKeys, arrItems Dim ws As Worksheet, rngKey As Range, arrKeySorted Dim ret As VbMsgBoxResult ret = MsgBox(是否复位, vbYesNo) If ret = vbNo Then md = Application.InputBox(请输入排列起始序号, 重新排列, 1, , , , , 1) If md 1 Then Exit Sub End If Set rng = Sheets(1).UsedRange.Offset(, 1).Resize(, Sheets(1).UsedRange.Columns.Count - 1) arr = rng Set oDict = CreateObject(scripting.dictionary) For i = 1 To UBound(arr, 2) oDict(arr(1, i) = Application.Index(arr, , i) Next i arrKeys = oDict.keys: arrItems = oDict.items Application.ScreenUpdating = False Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count) ws.Visible = 0 Set rngKey = ws.a1.Resize(UBound(arrKeys) + 1) rngKey = Application.Transpose(arrKeys) rngKey.Sort rngKey(1, 1) If ret = vbYes Then arrKeySorted = rngKey Else rngKey.Offset(, 1).FormulaR1C1 = =mod(RC-1, & Application.Max(md, 2) & ) If md = 1 Then rngKey.Resize(, 2).Sort rngKey(1, 2), xlDescending Else rngKey.Resize(, 2).Sort rngKey(1, 2) End If arrKeySorted = rngKey End If Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True Sheets(1).Activate For i = 1 To UBound(arr, 2) rng.Columns(i) = oDict(arrKeySorted(i, 1) Next i rng.EntireColumn.AutoFit Application.ScreenUpdating = TrueEnd Sub思路不错，一点建议：由于第一行是数字，用数组代替字典速度会不会提高些呢？Sub 排序2()Dim Arr, i&, j&, brr(), m&, z&, a(1 To 120)Arr = Range(Cells(1, 2), Cells(Cells(Rows.Count, 1).End(3).Row, 121)ReDim brr(1 To UBound(Arr), 1 To 120)For i = 1 To 120d(arr(1, i) = ia(Arr(1, i) = iNextm = 0md = Val(InputBox(请输入排列起始序号, 重新排列, 1)If md = 2 Then For j = md To 120 Step md m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, a(j) Next Next For i = 1 To md - 1 For j = i To 120 Step md m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, a(j) Next Next NextElseIf md = 1 Then For i = 1 To 2 For j = i To 120 Step 2 m = m + 1 For z = 1 To UBound(Arr) brr(z, m) = Arr(z, a(j) Next NextNextEnd Ifb1.Resize(UBound(brr), 120) = brrEnd Sub求助 有关Worksheet_Change(ByVal Target As Range)的问题 复制链接 请教高手，为了简化输入，建立了中英文对照的属性，想输入中文时，自动带出英文，输入英文时，自动带出中文，做了以下程序Private Sub Worksheet_Change(ByVal Target As Range)Dim attb_en, attb_cn As StringDebug.Print _ok_If Target.Column 11 Or Target.Column 12 Then Exit SubOn Error Resume NextIf Target.Column = 11 Then attb_en = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column + 1) = Application.Index(属性cn, Application.Match(attb_en, 属性en, 0) Exit SubEnd IfIf Target.Column = 12 Then attb_cn = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column - 1) = Application.Index(属性en, Application.Match(attb_cn, 属性cn, 0) Exit SubEnd IfEnd Sub为了调试中间加了Debug.Print _ok_语句，发现，第11列改变后触发程序，同时12列改变后也会触发程序本来想输入中文或英文，找出对应的英文或中文即停止，不知怎么调整请高手赐教谢谢加上不触发其它事件的代码.如Application.EnableEvents = FalseIf Target.Column = 11 Then attb_en = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column + 1) = Application.Index(属性cn, Application.Match(attb_en, 属性en, 0) Exit SubEnd IfIf Target.Column = 12 Then attb_cn = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column - 1) = Application.Index(属性en, Application.Match(attb_cn, 属性cn, 0) Exit SubEnd IfApplication.EnableEvents = True本来我自己加了个布尔变量，用于第二次触发程序时判断的，就是程序要运行两次，还是高手推荐的代码简练，学习了Private Sub Worksheet_Change(ByVal Target As Range)Dim attb_en, attb_cn As StringDim juj As BooleanDebug.Print _ok_If Target.Column 11 Or Target.Column 12 Then Exit SubOn Error Resume NextIf Target.Column = 11 Then juj = FalseElseIf Target.Column = 12 Then juj = TrueEnd IfIf Target.Column = 11 And Not juj Then attb_en = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column + 1) = Application.Index(属性cn, Application.Match(attb_en, 属性en, 0) juj = True Exit SubElse: Exit SubEnd IfIf Target.Column = 12 And juj Then attb_cn = Cells(Target.row, Target.Column) Cells(Target.row, Target.Column - 1) = Application.Index(属性en, Application.Match(attb_cn, 属性cn, 0) juj = False Exit SubElse: Exit SubEnd IfEnd SubPublic Sub Test()Dim b(), a(), m As Long, n As Longn = 1000000ReDim a(n, 1)For i = 1 To na(i, 1) = Int(n * Rnd()Nextb = at = Timerm = 1Call SortA(b(), m, n)e1 = Timer - td1 = 灰袍法师的希尔排序用时：Range(a1).Resize(n) = bRange(b1).Resize(n) = at = TimerRange(b1).Resize(n).Sort b1e2 = Timer - td2 = 工作表排序用时：End SubSub SortA(ArrKey(), L As Long, R As Long)Dim i As Long, j As Long, k As Long, h As Long, max_h As Long, offset As Long, swap_count As Long, one As LongDim Insert, h_arr() As Long, temp_h, temp_h2temp_h = Array(1, 5, 19, 41, 109, 209, 505, 929, 2161, 3905, 8929, 16001, 36289, 64769, 146305, 260609, 587521, 1045055, 2354689, 4188161, 9427969)此增量序列也是拥有 O(N1.25)的阶，但是明显比 h(n+1) = 3 * h(n) + 1更高效temp_h2 = Array(1, 5, 19, 41, 109, 211, 503, 929, 2161, 3907, 8929, 16001, 36293, 64763, 146309, 260609, 587527, 1045055, 2354689, 4188161, 9427969)ReDim h_arr(LBound(temp_h2) To UBound(temp_h2)h_arr(LBound(h_arr) = 1For i = LBound(h_arr) + 1 To UBound(h_arr)h_arr(i) = 2.25 * h_arr(i - 1) + 1此增量序列拥有 O(N1.25)的阶，但是速度也略为不如上面的序列1,5,19,41h_arr(i) = 3 * h_arr(i - 1) + 1 此增量序列拥有 O(N1.25)的阶，但是速度明显不如上面的2.25序列h_arr(i) = temp_h2(i)If h_arr(i) 2 31 / 2.25 Then Exit ForNext iIf max_h LBound(h_arr) Then max_h = LBound(h_arr)one = 1For i = max_h To LBound(h_arr) Step -oneh = h_arr(i)swap_count = 0For offset = 0 To h - 1 For j = L + offset To R Step h Insert = ArrKey(j, 1) For k = j - h To L + offset St