昱得資訊工作室
麻辣學園
歡迎光臨, 訪客. 請先 登入註冊一個帳號.
2014-10-21, 11:54:21
昱得資訊工作室
首頁 說明 登入 註冊 想當作者?
新聞: 會員注意!!麻辣家族討論區已轉換新系統,請移駕[麻辣家族新論壇]!!


+  麻辣家族討論區
|-+  MS Office 系列
| |-+  EXCEL
| | |-+  Excel程式區 (版主: Hsieh)
| | | |-+  如何讓 Excel vba 自動判斷到相對位置作篩選
0 會員 以及 1 訪客 正在閱讀本篇主題. « 上一篇主題 下一篇主題 »
頁: [1] 2 向下 列印
作者 主題: 如何讓 Excel vba 自動判斷到相對位置作篩選  (閱讀 5858 次)
易安
易安
中學生
*
離線 離線

會員性別: 男
文章: 92



如何讓 Excel vba 自動判斷到相對位置作篩選
« 於: 2009-03-17, 14:19:25 »

 Sheets("程式").Select
  For k = 14 To 62
  Criter = CStr(k - 13)
  Range(Cells(4, k), Cells(2000, k)).Select
  Selection.Copy
  Range("M5").Select
  ActiveSheet.Paste
  Columns("M:M").Select
  Application.CutCopyMode = False
  Selection.AutoFilter
  Selection.AutoFilter Field:=1, Criteria1:=Criter
  nn2
  Selection.Copy
  Sheets("統計").Select
  ActiveSheet.Paste
  Application.Run "zz.xls!分析"
  Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k - 26)
  Sheets("統計").Select
  Application.Run "zz.xls!清除"
  Sheets("程式").Select
  Columns("M:M").Select
  Selection.ClearContents
  
  Next
 
End Sub

--------------------------------------------------------------
以上程序是將 N ~ BJ 的值依序拷貝到M5的位置,然後篩選後.只取倒數最後2列的資料備份到"統計"去分析.

由於 N ~ BJ 共需執行49次.但因為小弟只需要以(F1 ~ L1)的數據去取相對位置的值複製到"M5"作篩選.所以只要執行7次即可.

所以想請問:

如何將附件 ZZ 裡的 N ~ BJ 的內容以(F1 ~ L1)的數據作判斷,分別複製到"M5"的位置作篩選.
例:
F1的號碼是 2,將複製 O4~O2000 的數值複製到"M5"作篩選.
G1的號碼是 9,將複製 V4~V2000 的內容複製到"M5"作篩選.
.
.
L1的號碼是44,將複製 BE4~BE2000 的內容複製到"M5"作篩選.
以此類推.

P.S:因為(F1 ~ L1)的數據,每次作業會變更.如何讓 Excel vba 自動判斷並分別複製適當地內容到"M5"的位置作篩選.

謝謝

* ZZ.rar (0 KB - 已被下載 5 次.)
已記錄

非常感謝解答的諸位老師--感謝您
GBKEE
47年次
碩士班
*
離線 離線

文章: 1450



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #1 於: 2009-03-18, 00:51:37 »

程式碼:
Sub 原本()
  Sheets("程式").Select
  For Each k In [F1:L1]
    Columns("M:M") = ""
    Range(Cells(4, k + 13), Cells(2000, k + 13)).SpecialCells(xlCellTypeConstants).Copy [M5]
    nn2
    Selection.Copy
    Sheets("統計").Select
    ActiveSheet.Paste
    Application.Run "zz.xls!分析"
    Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k - 26)
    Sheets("統計").Select
    Application.Run "zz.xls!清除"
    Sheets("程式").Select
    'Columns("M:M").Select
    'Selection.ClearContents
  Next
End Sub
已記錄

知道的不多,不知道的更多. 不知道就請問! 知道會更多,不知道會不多.
Hsieh
版主
*
離線 離線

會員性別: 男
文章: 5729



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #2 於: 2009-03-18, 06:44:25 »

程式碼:
Sub 原本()
'
' 原本 Macro
' TIGER-XP 在 2009/3/17 錄製的巨集
'
Dim Ar(), Rng As Range, MyRng As Range, MyCell As Range
Set d = CreateObject("Scripting.Dictionary")

With Sheets("程式")
Set Rng = .[F1:L1]
For k = 1 To 7
kc = Rng(k)
Set MyRng = Columns(kc + 13).SpecialCells(xlCellTypeConstants)
For Each a In MyRng
ReDim Preserve Ar(s)
Ar(s) = a.Row
s = s + 1
Next
For r = UBound(Ar) - 1 To UBound(Ar)
If MyCell Is Nothing Then
Set MyCell = .Range("N" & Ar(r) & ":BJ" & Ar(r))
Else
Set MyCell = Union(MyCell, .Range("N" & Ar(r) & ":BJ" & Ar(r)))
End If
Next
For Each a In MyCell.SpecialCells(xlCellTypeConstants)
d(a.Text) = d(a.Text) + 1
Next
With Sheets("統計")
.Range("A3:B65536").ClearContents
.[A3].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[B3].Resize(d.Count, 1) = Application.Transpose(d.items)
.Range(.[A3], .[B65536].End(xlUp)).Sort Key1:=.[B3], Order1:=xlDescending
.Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k)
.Columns("H:BI") = ""
.[A3:B65536] = ""
End With
Next
End With
End Sub
已記錄

回答滿意嗎?
  記得告訴我哦!!
易安
易安
中學生
*
離線 離線

會員性別: 男
文章: 92



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #3 於: 2009-03-18, 13:25:15 »

GBKEE 大大:

感謝您的回覆.但是您的 vba 在執行的過程中出現.
"執行階段錯誤13"型態不符合...的說明.

hsieh 老師您好:
感謝您再一次的幫忙,基本上都能符合小弟的需求.
不過有下列兩各問題想請老師再改一下.謝謝.

1.原始程序是將N4 ~ BJ2000 的值依序拷貝到M5的位置.換一種寫法希望將N ~ BJ 的值依序拷貝到 M 的位置,然後再 M1 位置"插入-現有儲存格下移".

For k = 14 To 62
Criter = CStr(k - 13)
Range(Cells(4, k), Cells(2000, k)).Select
Selection.Copy
Range("M5").Select

2.以(F1 ~ L1)的數據作判斷,分別複製到"M5"的位置作篩選.
當 F1 分析完畢備份到組織後,不知道是哪裡的數值沒刪除乾淨導致
G1 ~ L1 後面的分析數據有累加的現象喔.

Application.Run "zz.xls!分析"
Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k - 26)
Sheets("統計").Select
Application.Run "zz.xls!清除"

3.Sub nn2()
While i < 2 And r > 1  '2 是指只抓取最後2列的資料.
小地址需修改將2的數據.改任一數(如7)則可將篩選取最後7列的資料.
不知道老師您的程式.小弟若要變動該改哪裡阿

Sub nn2()

Dim Rng As Range, MyRng As Range, MyFiltre As AutoFilter
If ActiveSheet.FilterMode = True Then
Set Rng = ActiveSheet.AutoFilter.Range
r = Rng.Rows.Count
While i < 2 And r > 1  '2 是指只抓取最後2列的資料
If Rows(r).Hidden = False Then
i = i + 1
If MyRng Is Nothing Then
Set MyRng = Range("N" & r & ":BJ" & r)
Else
Set MyRng = Union(MyRng, Range("N" & r & ":BJ" & r))
End If
End If
r = r - 1
Wend
MyRng.Select
End If
End Sub
已記錄

非常感謝解答的諸位老師--感謝您
Hsieh
版主
*
離線 離線

會員性別: 男
文章: 5729



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #4 於: 2009-03-18, 13:45:01 »

Sub 原本()
'
' 原本 Macro
' TIGER-XP 在 2009/3/17 錄製的巨集
'
Dim Ar(), Rng As Range, MyRng As Range, MyCell As Range
Set d = CreateObject("Scripting.Dictionary")

With Sheets("程式")
Set Rng = .[F1:L1]
For k = 1 To 7
kc = Rng(k)
Set MyRng = Columns(kc + 13).SpecialCells(xlCellTypeConstants)
For Each a In MyRng
ReDim Preserve Ar(s)
Ar(s) = a.Row
s = s + 1
Next
For r = UBound(Ar) - 1 To UBound(Ar)
If MyCell Is Nothing Then
Set MyCell = .Range("N" & Ar(r) & ":BJ" & Ar(r))
Else
Set MyCell = Union(MyCell, .Range("N" & Ar(r) & ":BJ" & Ar(r)))
End If
Next
For Each a In MyCell.SpecialCells(xlCellTypeConstants)
d(a.Text) = d(a.Text) + 1
Nex
Set MyCell=Nothing'把變數歸零
With Sheets("統計")
.Range("A3:B65536").ClearContents
.[A3].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[B3].Resize(d.Count, 1) = Application.Transpose(d.items)
.Range(.[A3], .[B65536].End(xlUp)).Sort Key1:=.[B3], Order1:=xlDescending
.Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k)
.Columns("H:BI") = ""
.[A3:B65536] = ""
End With
Next
End With
End Sub
差紅色那一句
已記錄

回答滿意嗎?
  記得告訴我哦!!
易安
易安
中學生
*
離線 離線

會員性別: 男
文章: 92



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #5 於: 2009-03-18, 14:09:39 »

hsieh 老師您好:
原先想請教的目標是可行的.
但是程式跑出來的結果差很多.
小弟附件內有用手工將結果另存.
請老師幫忙再看看
謝謝

* ZZ.rar (0 KB - 已被下載 4 次.)
已記錄

非常感謝解答的諸位老師--感謝您
Hsieh
版主
*
離線 離線

會員性別: 男
文章: 5729



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #6 於: 2009-03-18, 14:15:21 »

程式碼:
Sub 原本()
'
' 原本 Macro
' TIGER-XP 在 2009/3/17 錄製的巨集
'
Dim Ar(), Rng As Range, MyRng As Range, MyCell As Range
Set d = CreateObject("Scripting.Dictionary")

With Sheets("程式")
Set Rng = .[F1:L1]
For k = 1 To 7
kc = Rng(k)
Set MyRng = .Columns(kc + 13).SpecialCells(xlCellTypeConstants)
For Each a In MyRng
ReDim Preserve Ar(s)
Ar(s) = a.Row
s = s + 1
Next
For r = UBound(Ar) - 1 To UBound(Ar)
If MyCell Is Nothing Then
Set MyCell = .Range("N" & Ar(r) & ":BJ" & Ar(r))
Else
Set MyCell = Union(MyCell, .Range("N" & Ar(r) & ":BJ" & Ar(r)))
End If
Next
For Each a In MyCell.SpecialCells(xlCellTypeConstants)
d(a.Text) = d(a.Text) + 1
Next
Set MyCell = Nothing '把變數歸零
With Sheets("統計")
.Range("A3:B65536").ClearContents
.[A3].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[B3].Resize(d.Count, 1) = Application.Transpose(d.items)
d.RemoveAll '清空dictionary
.Range(.[A3], .[B65536].End(xlUp)).Sort Key1:=.[B3], Order1:=xlDescending
.Range("A2:B51").Copy Sheets("組織").Cells(2, 2 * k)
.Columns("H:BI") = ""
.[A3:B65536] = ""
End With
Next
End With
已記錄

回答滿意嗎?
  記得告訴我哦!!
易安
易安
中學生
*
離線 離線

會員性別: 男
文章: 92



Re: 如何讓 Excel vba 自動判斷到相對位置作篩選
« 回覆文章 #7 於: 2009-03-18, 14:39:15 »

hsieh 老師您好:
經過幾次修正大部份都可以了.只剩下這個問題.


For k = 14 To 62
Criter = CStr(k - 13)
Range(Cells(4, k), Cells(2000, k)).Select '原始程序是將N4 ~ BJ2000 的值依序拷貝到M5的位置
Selection.Copy
Range("M5").Select

而老師您是將N ~ BJ 的值依序拷貝到 M 的位置就做篩選,
可否再 M1 位置"插入-現有儲存格下移".在做篩選阿.

也就是說原本在N ~ BJ 所有的值,在複製到 M 後.希望將原先數值的位置往下移一格.在做篩選.
謝謝
已記錄

非常感謝解答的諸位老師--感謝您
頁: [1] 2 向上 列印 
« 上一篇主題 下一篇主題 »
自訂搜尋
跳到:  


Google PageRank Checker
本頁花了 4.522 秒, 以及 20 次的資料庫查詢.