帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2016-10-12 16:12 | 只看該作者

[發問] 如何用迴圈，將ADD_M欄中有含字母併計

請問，迴圈中，判斷式，可加入字母嗎？

問題51.rar (271.19 KB)

樓主熱帖

希望支持!

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

11^#

發表於 2016-10-26 13:33 | 只看該作者

回復 10# s7659109

Excel程式區是討論如何使用VBA.學習,發問.
附檔xlsx是沒有程式碼的Excel檔.至少給點程式碼.
多少要認識一下VBA,給你程式碼才對你有幫助.

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

s7659109

中學生 Rank: 2

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

10^#

發表於 2016-10-26 10:02 | 只看該作者

如何用迴圈，將ADD_M欄中有含字母併計(進階需求版)

大大：
問題：根據輸入條件，輸出明細二張表與彙計，其中日期要轉換，有固定列在第一列之條件，還有特殊條件需求

問題52.rar (17.25 KB)

希望支持!

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2016-10-23 11:06 | 只看該作者

回復 7# s7659109
擴大資料庫的準則範圍為二欄

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range
Set Rng(1) = Range("B:D").SpecialCells(xlCellTypeConstants) '**資料庫
Set Rng(2) = Cells(1, Columns.Count - 1).Resize(2, 2) '**資料庫的準則範圍,CriteriaRange
Set Rng(3) = Range("G2,K2") '**資料庫的準則範圍,CopyToRange
Rng(3)(1).CurrentRegion.Clear
Rng(3).Areas(2).CurrentRegion.Clear
'** 資料庫的準則為 "計算式準則",準則欄位名稱不可與資料庫的欄位名稱相同 ****
Rng(2).Cells(1, 1) = "TEST" '資料庫的準則欄位名稱
Rng(2).Cells(2, 1) = "=VALUE(MID(ADD_M,1,1))<2" ''篩選資料庫的準則 , 計算式準則
Rng(2).Cells(1, 2) = "ADD" '資料庫的準則欄位名稱
Rng(2).Cells(2, 2) = "A001" ''篩選資料庫的準則
'**MID(ADD_M,1,1) -> 資料庫欄位 "ADD_M" 的第一個字串"
'**=VALUE(MID(ADD_M,1,1))<2 第一個字串小於2
Rng(1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng(2), CopyToRange:=Rng(3).Cells(1), Unique:=False
Rng(3).Cells(0) = "小計"
Rng(3).Cells(0, 3) = Application.Sum(Rng(3).Cells(0, 3).EntireColumn)
Rng(2).Cells(2, 1) = "=VALUE(MID(ADD_M,1,1))>=2"
'**=VALUE(MID(ADD_M,1,1))<2 第一個字串大於等於2
Rng(1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng(2), CopyToRange:=Rng(3).Areas(2), Unique:=False
Rng(3).Areas(2).Cells(0) = "小計"
Rng(3).Areas(2).Cells(0, 3) = Application.Sum(Rng(3).Areas(2).Cells(0, 3).EntireColumn)
Rng(2).Clear
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

8^#

發表於 2016-10-21 16:53 | 只看該作者

題意不清, 就無法回應!!!

Sub TEST()
Dim T$, Arr, Brr, Crr, Bn&, Cn&, Sb, Sc, i&, j%
[G3:I6000,K3:M6000].ClearContents: [I1,M1] = ""
If [G1] = "" Then Exit Sub
Arr = Range("B2:D" & Cells(Rows.Count, 2).End(xlUp).Row)
ReDim Brr(1 To UBound(Arr), 1 To 3): Crr = Brr
For i = 1 To UBound(Arr)
If Arr(i, 1) <> [G1] Then GoTo 101
If Left(Arr(i, 2), 1) Like "[0-1]" Then
Bn = Bn + 1: Sb = Sb + Val(Arr(i, 3))
For j = 1 To 3: Brr(Bn, j) = Arr(i, j): Next
ElseIf Left(Arr(i, 2), 1) Like "[2-9]" Then
Cn = Cn + 1: Sc = Sc + Val(Arr(i, 3))
For j = 1 To 3: Crr(Cn, j) = Arr(i, j): Next
End If
101: Next i
If Bn > 0 Then [G3:I3].Resize(Bn) = Brr: [I1] = Sb
If Cn > 0 Then [K3:M3].Resize(Cn) = Crr: [M1] = Sc
End Sub

複製代碼

Xl0000193.rar (20.08 KB)

TOP

s7659109

中學生 Rank: 2

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

7^#

發表於 2016-10-21 13:56 | 只看該作者

本帖最後由 s7659109 於 2016-10-21 13:58 編輯

版主：
謝謝版主解惑，但結果1與2中ADD欄，只要A001,其它的不列入，故
TOTAL與明細有誤。

問題51_2.rar (368.06 KB)

希望支持!

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2016-10-21 13:11 | 只看該作者

回復 5# s7659109
用進階篩選試試看

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range
Set Rng(1) = Range("B:D").SpecialCells(xlCellTypeConstants) '**資料庫
Set Rng(2) = Cells(1, Columns.Count).Resize(2) '**資料庫的準則範圍,CriteriaRange
Set Rng(3) = Range("G2,K2") '**資料庫的準則範圍,CopyToRange
Rng(3)(1).CurrentRegion.Clear
Rng(3).Areas(2).CurrentRegion.Clear
'** 資料庫的準則為 "計算式準則",準則欄位名稱不可與資料庫的欄位名稱相同 ****
Rng(2).Cells(1) = "TEST" '資料庫的準則欄位名稱
Rng(2).Cells(2) = "=VALUE(MID(ADD_M,1,1))<2" ''篩選資料庫的準則 , 計算式準則
'**MID(ADD_M,1,1) -> 資料庫欄位 "ADD_M" 的第一個字串"
'**=VALUE(MID(ADD_M,1,1))<2 第一個字串小於2
Rng(1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng(2), CopyToRange:=Rng(3).Cells(1), Unique:=False
Rng(3).Cells(0) = "小計"
Rng(3).Cells(0, 3) = Application.Sum(Rng(3).Cells(0, 3).EntireColumn)
Rng(2).Cells(2) = "=VALUE(MID(ADD_M,1,1))>=2"
'**=VALUE(MID(ADD_M,1,1))<2 第一個字串大於等於2
Rng(1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Rng(2), CopyToRange:=Rng(3).Areas(2), Unique:=False
Rng(3).Areas(2).Cells(0) = "小計"
Rng(3).Areas(2).Cells(0, 3) = Application.Sum(Rng(3).Areas(2).Cells(0, 3).EntireColumn)
Rng(2).Clear
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

s7659109

中學生 Rank: 2

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

5^#

發表於 2016-10-21 08:50 | 只看該作者

本帖最後由 s7659109 於 2016-10-21 08:52 編輯

版主：我是一個VBA初學者，謝謝你的提醒
我的問題：是利用迴圈將原始資料(左側_我有加大資料，請考慮每天都會新增資料，自動更新),求出
結果1:是將ADD欄中A001 且ADD_M中001~199區間(包含有字母一併計入，如1Y1,1A5,07Z等等)累計，並列出明細
結果2:是將ADD欄中A001 且ADD_M中200~999區間(包含有字母一併計入，如2G0,,28J等等)累計，並列出明細

問題51_.rar (244.07 KB)