Board logo

標題: [發問] 非常複雜選擇跟比對,當選擇H2時,可以得到 I2:L12 的結果? [打印本頁]
作者: metrostar    時間: 2013-8-25 10:52     標題: 非常複雜選擇跟比對,當選擇H2時,可以得到 I2:L12 的結果?

學妹又來麻煩大家了
打開 EXCEL 檔有詳細說明喔
請帥哥/美女版主 帥哥/美女學長跟學姐
幫忙學妹完成
謝謝了
作者: luhpro    時間: 2013-8-27 00:21

學妹又來麻煩大家了
打開 EXCEL 檔有詳細說明喔
請帥哥/美女版主 帥哥/美女學長跟學姐
幫忙學妹完成
謝 ...
metrostar 發表於 2013-8-25 10:52
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.   Dim iCount1%, iCount2%, iI%
  3.   Dim lRow As Long, lRows As Long, lTRow As Long
  4.   Dim sMod1$, sMod2$
  5.   Dim bUse As Boolean
  6.   
  7.   With Target
  8. Application.EnableEvents = False
  9.     Range(.Offset(, 1), .Offset(10, 4)).Delete Shift:=xlShiftToLeft
  10.     If .Row = 2 And .Column = 8 Then '[H2]
  11.       With .Parent
  12.         lRow = .Cells(Rows.Count, 1).End(xlUp).Row
  13.         lRows = .Cells(Rows.Count, 5).End(xlUp).Row
  14.         If lRow > lRows Then lRows = lRow
  15.         lTRow = 0
  16.         bUse = False
  17.         For lRow = 2 To lRows
  18.           If Trim(.Cells(lRow, 1).Text) = Trim(Target) Then
  19.             Target.Offset(lTRow, 1) = .Cells(lRow, 2)
  20.             Target.Offset(lTRow, 2) = .Cells(lRow, 3)
  21.             bUse = True
  22.           End If
  23.          
  24.           If Trim(.Cells(lRow, 5).Text) = Trim(Target) Then
  25.             Target.Offset(lTRow, 3) = .Cells(lRow, 4)
  26.             Target.Offset(lTRow, 4) = .Cells(lRow, 6)
  27.             bUse = True
  28.           End If
  29.           If bUse Then lTRow = lTRow + 1
  30.         Next lRow
  31.       End With
  32.     End If
  33.     With Range(.Offset(, 1), .Offset(10, 4))
  34.       .Interior.ColorIndex = 39
  35.       .VerticalAlignment = xlCenter
  36.       .HorizontalAlignment = xlCenter
  37.       .Borders.LineStyle = xlContinuous
  38.     End With
  39. Application.EnableEvents = True
  40.   End With
  41. End Sub
複製代碼
[attach]15862[/attach]
作者: Hsieh    時間: 2013-8-29 15:13

回復 1# metrostar
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim A As Range, C As Range, Ar()
  3. If Intersect(Target, [H2]) Is Nothing Then Exit Sub
  4. Set A = [E:E].Find(Target, lookat:=xlWhole)
  5. If A Is Nothing Then Exit Sub
  6. ReDim Preserve Ar(s)
  7. Ar(s) = Array([B1].Value, [C1].Value, [D1].Value, [F1].Value)
  8. s = s + 1
  9.    For Each C In A.MergeArea
  10.      ReDim Preserve Ar(s)
  11.      Ar(s) = Array(C.Offset(, -3).MergeArea(1).Value, C.Offset(, -2).MergeArea(1).Value, C.Offset(, -1).MergeArea(1).Value, C.Offset(, 1).MergeArea(1).Value)
  12.      s = s + 1
  13.     Next
  14. Application.EnableEvents = False
  15. [I:L] = ""
  16. With Range("I1")
  17.    .Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
  18.    .CurrentRegion.Offset(, 1).Sort key1:=.Range("A1"), Header:=xlYes
  19. End With
  20. Application.EnableEvents = True
  21. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)