返回列表 上一主題 發帖

[發問] 從一個儲存格資料，拆到多個儲存格欄位中

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-9-25 10:48 | 只看該作者

[發問] 從一個儲存格資料，拆到多個儲存格欄位中

Dear 大大

          附件是我問題的範本，主要的問題有2
          1. 撰寫好後，在執行的時候，就會產生excel無反應的現象，該怎麼處理為好呢?
          2. 從一個儲存格內把資料拆到好幾個欄位，我寫的方式比較複雜(用判斷的方式一個字元一個字元來處理)
               不知道有沒有更好的處理方式呢???


eeeeeeeeeee.rar (17.63 KB)
收藏 分享
學習才能提升自己

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2014-9-25 11:00 | 只看該作者
回復 1# hugh0620

把你這筆資料要拆成怎樣的欄位用人工方式填入後上傳
以便了解你要的結果為何?
學海無涯_不恥下問

TOP

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
3#
發表於 2014-9-26 13:42 | 只看該作者
回復 2# Hsieh

Dear 大大

         附件是我修改好的，不知道有沒有更簡便的撰寫方式。
         (我自己有找到bug在哪邊，已經可以跑出我要的結果)
        另外有一句程式碼需要大大給點意見，如下句：
        patch = Application.GetOpenFilename("Microsoft Excel 活頁簿 (*.xls), *.xls")
        現在的excel都有.xls 或 .xlsx ，如果用上面的句子只會顯示.xls的檔案
        要如何大小通吃把excel檔全叫出來呢???

eeee.rar (206.14 KB)
學習才能提升自己

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
4#
發表於 2014-9-26 23:24 | 只看該作者
本帖最後由 luhpro 於 2014-9-26 23:26 編輯
回復  Hsieh
Dear 大大
另外有一句程式碼需要大大給點意見，如下句：
        patch = Application.GetOpenFilename("Microsoft Excel 活頁簿 (*.xls), *.xls")
        現在的excel都有.xls 或 .xlsx ，如果用上面的句子只會顯示.xls的檔案
        要如何大小通吃把excel檔全叫出來呢???
hugh0620 發表於 2014-9-26 13:42

先回覆這一個 -
該函式的說明內就有答案了喔:

GetOpenFilename 方法
顯示標準的 [開啟舊檔] 對話方塊，並取得使用者檔案名稱，而不必真正開啟任何檔案。
expression.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
expression     必選。該運算式傳回 Application 物件。
FileFilter     選擇性的 Variant。是指定檔案篩選規則的字串。
此字串由一檔案篩選字串與 MS-DOS 萬用字元表達的檔案篩選規則描述組成，中間以逗點分隔。
[檔案類型] 下拉式清單方塊中會列出各組字串。例如，下列字串指定兩個檔案篩選，
文字和增益集：文字檔 (*.txt),*.txt,增益集檔案 (*.xla),*.xla。
若要使用多個 MS-DOS 萬用字元運算式組成單一檔案篩選類型，各萬用字元之間需以分號分隔；
例如，"Visual Basic Files (*.bas; *.txt),*.bas;*.txt"。
如果省略，則此引數將預設為 "All Files (*.*),*.*"。

所以你可以用:

patch = Application.GetOpenFilename("Microsoft Excel 活頁簿 (*.xls;*.xlsx), *.xls; *.xlsx")

來解決.

TOP

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
5#
發表於 2014-9-27 09:14 | 只看該作者
回復 4# luhpro


    謝謝指導~  長知識~ 以後就知道怎麼運用~  :)
學習才能提升自己

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
6#
發表於 2014-9-27 12:45 | 只看該作者
本帖最後由 luhpro 於 2014-9-27 12:49 編輯
回復  Hsieh
Dear 大大
         附件是我修改好的，不知道有沒有更簡便的撰寫方式。
...
hugh0620 發表於 2014-9-26 13:42

eeee-a.zip (20.08 KB)
22行以上的部分你可以考慮用你原來的方式,
看起來會比較簡單.
底下我只是嘗試著把它們都放入同一個迴圈內.
  1. Private Sub CommandButton1_Click()
  2.   Application.ScreenUpdating = False
  3.   
  4.   [B3].Resize(Rows.Count - 2, Columns.Count - 1).Clear
  5.   lRow = 3
  6.   bChk = False
  7.   Do While Cells(lRow, 1) <> ""
  8.     With Cells(lRow, 1)
  9.       sStr = Trim(.Value)
  10.       sChk = Left(sStr, 3)
  11.       If sChk = "P/O" Then
  12.         sPo = Mid(sStr, 9)
  13.         .Offset(, 1) = sPo
  14.         .Offset(, 2) = sPo
  15.       ElseIf sChk = "COL" Then
  16.         sCo = Mid(sStr, 6)
  17.         .Offset(, 1) = sCo
  18.         .Offset(, 2) = sPo
  19.         .Offset(, 3) = sCo
  20.         .Offset(-1, 3) = sCo
  21.       Else
  22.         .Offset(, 2) = sPo
  23.         .Offset(, 3) = sCo
  24.         iCnt = 0
  25.         iPos = 1
  26.         Do While iPos <= Len(sStr)
  27.           If InStr(iPos, sStr, "(") <> 0 Then
  28.             iPos = InStr(iPos, sStr, "(") + 1
  29.             iCnt = iCnt + 1
  30.           Else
  31.             Exit Do
  32.           End If
  33.         Loop
  34.         With .Offset(, 4)
  35.           .Value = sStr
  36.           .TextToColumns Space:=True
  37.         End With
  38.         .Offset(, 5 + iCnt).Resize(, 3).Cut .Offset(, 20)
  39.          For iPos = 20 To 22
  40.            .Offset(, iPos) = Val(.Offset(, iPos)) ' 後面計算會用到,所以先轉換成數值
  41.          Next
  42.         vNw1 = 0
  43.         vNw2 = 0
  44.         For iPos = iCnt - 1 To 0 Step -1
  45.           With .Offset(, 5 + iPos)
  46.             .Cut .Offset(, iPos * 2)
  47.             With .Offset(0)
  48.               .TextToColumns Other:=True, OtherChar:="("
  49.               sStr = .Offset(, 1)
  50.               With .Offset(, 1)
  51.                 .NumberFormat = "@"
  52.                 .Value = Left(sStr, Len(sStr) - 1)
  53.               End With
  54.             End With
  55.           End With
  56.           If iPos <> iCnt - 1 Then
  57.             vNw1 = Round((.Offset(, 5 + iPos * 3) / .Offset(, 20)) * .Offset(, 21), 2)
  58.             .Offset(, 7 + iPos * 3) = vNw1
  59.             vNw2 = vNw2 + vNw1
  60.           End If
  61.         Next
  62.         .Offset(, 4 + iCnt * 3) = .Offset(, 21) - vNw2
  63.       End If
  64.     End With
  65.     lRow = lRow + 1
  66.   Loop
  67.   Application.ScreenUpdating = True
  68. End Sub
複製代碼

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2014-9-29 16:32 | 只看該作者
回復 3# hugh0620
  1. Sub ex()
  2. For Each a In Range([A5], [A5].End(xlDown))
  3. n = Split(a, "KGS")(0) '取到第一個KGS
  4. mystr = Replace(Replace(Replace(Replace(Replace(n, "A", "A("), ")", "("), "YDS", "("), "KGS", "("), " ", "") '用左括號取代分隔位置
  5. ar = Split(mystr, "(") '用左括號做分隔
  6. y = Val(ar(UBound(ar) - 1)) 'YDS的值
  7. k = Val(ar(UBound(ar))) 'KGS的值
  8. s = UBound(ar)
  9. Dim ay()
  10. ReDim Preserve ay(0)
  11. ay(0) = ar(0)
  12. For i = 1 To (s - 2) / 2
  13. x = UBound(ay) + 1
  14. ReDim Preserve ay(x + 2)
  15. n = (i - 1) * 2 + 1
  16. ay(x) = Val(ar(n))
  17. ay(x + 1) = "'" & ar(n + 1)
  18. ay(x + 2) = Round(ar(n) / y * k, 2)
  19. Next
  20. a.Offset(, 4).Resize(, UBound(ay) + 1) = ay
  21. Erase ay
  22. Next
  23. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題