返回列表 上一主題 發帖

[發問] 非常複雜選擇跟比對,當選擇H2時,可以得到 I2:L12 的結果?

metrostar

帖子
55 
主題
20 
精華
0 
積分
80 
點名
0  
作業系統
winxp 
軟體版本
officexp 
閱讀權限
20 
性別
女 
註冊時間
2010-7-5 
最後登錄
2013-8-25 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-8-25 10:52 | 只看該作者

[發問] 非常複雜選擇跟比對,當選擇H2時,可以得到 I2:L12 的結果?

學妹又來麻煩大家了
打開 EXCEL 檔有詳細說明喔
請帥哥/美女版主 帥哥/美女學長跟學姐
幫忙學妹完成
謝謝了

metrostar201308.rar (3.85 KB)

收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 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
複製代碼
metrostar201308-a.zip (11.25 KB)

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
258  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-28 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 要用心，不要操心、煩心。
返回列表 上一主題