12
返回列表 上一主題 發帖

[發問] 核取方塊 回存資料 PART~2

kai6929

帖子
84 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
xp 
軟體版本
offcie 2007 
閱讀權限
20 
註冊時間
2010-5-6 
最後登錄
2024-2-17 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2012-11-6 14:34 | 只看該作者

[發問] 核取方塊 回存資料 PART~2

大師好
           此巨集為某大師幫忙完成之傑作,想在改成達到以下的功能是否可幫幫忙,  
1.首先在Sheet1 底下輸入資料後按下
■加工一  C25:= 1    ■加工一  C26:= 1    ■加工一  C27:= 1   
2.SHEET2 呈現結果如下   項次 L 13以下 自動產生
3.在Sheet1 底按下
□加工一  C25:= 0    □加工一  C26:= 0    □加工一  C27:= 0  
4.SHEET2 呈現結果如下   項次 L13:S27以下 清除內容


Option Explicit
Sub check()
    Dim K As String, M As Boolean, xRow As Integer, xi As Integer
    With ActiveSheet.Shapes(Application.Caller)
        With .TextFrame
            K = .Characters.Text
            If Left(K, 1) = "■" Then
                .Characters.Text = "□加工一"
                M = False
            Else
                .Characters.Text = "■加工一"
                M = True
            End If
            .Characters(1, Len(K) + 1).Font.Size = 10
            .Characters(1, 1).Font.Size = 10
        End With
        .TopLeftCell.Offset(, 1) = M
        .TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
    End With
    Sheet2.UsedRange("L13:S27").ClearContents
    xRow = 25
    With ActiveSheet
    Do While .Cells(xRow, "C") <> ""
        If .Cells(xRow, "C") = 1 Then
            xi = xi + 1
            Sheet2.Rows(1).Copy Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
           With Sheet2.Cells(Rows.Count, "A").End(xlUp)
           .Cells(1) = xi
           .Cells(12, 14) = ActiveSheet.Cells(xRow, "F")
           .Cells(12, 17) = ActiveSheet.Cells(xRow, "H")
           .Cells(12, 18) = ActiveSheet.Cells(xRow, "J")
           .Cells(12, 19) = ActiveSheet.Cells(xRow, "K")
           End With
        End If
        xRow = xRow + 1
    Loop
    End With
End Sub
kai~20.rar (72.82 KB)
1

評分人數

    • GBKEE: 重複發帖金錢 -1
收藏 分享

kai6929

帖子
84 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
xp 
軟體版本
offcie 2007 
閱讀權限
20 
註冊時間
2010-5-6 
最後登錄
2024-2-17 
13#
發表於 2012-11-7 17:30 | 只看該作者
回復 12# GBKEE

大師可以給我您的 E-mail 我寄給您過目

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 2012-11-7 16:54 | 只看該作者
回復 11# kai6929
上傳修改的檔案 看看

TOP

kai6929

帖子
84 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
xp 
軟體版本
offcie 2007 
閱讀權限
20 
註冊時間
2010-5-6 
最後登錄
2024-2-17 
11#
發表於 2012-11-6 18:11 | 只看該作者
回復 10# GBKEE
請大師指導一下 感謝

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2012-11-6 18:01 | 只看該作者
回復 8# kai6929
那程式碼是給Sheet2用的,資料又要改放Sheet1,有關Sheet2的程式碼,那你要改一下

TOP

kai6929

帖子
84 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
xp 
軟體版本
offcie 2007 
閱讀權限
20 
註冊時間
2010-5-6 
最後登錄
2024-2-17 
9#
發表於 2012-11-6 17:32 | 只看該作者

放在我原有的  Sheet1 便不能使用為什麼?

TOP

kai6929

帖子
84 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
xp 
軟體版本
offcie 2007 
閱讀權限
20 
註冊時間
2010-5-6 
最後登錄
2024-2-17 
8#
發表於 2012-11-6 17:27 | 只看該作者
本帖最後由 kai6929 於 2012-11-6 17:28 編輯

大師真的是厲害的很.
二三下就解決我的問題,但有一事我不明白為何此巨集放到我的 Sheet1 便不能使用.
可以指導一下嗎

TOP

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
7#
發表於 2012-11-6 16:54 | 只看該作者
回復 6# GBKEE

其實 是因為我之前犯過..
被糾正 哈哈

  多做多想多學習，少看少錯少迷途

  多做=多多練習，多多編寫。
  多想=想想為什麼人家程式要那樣寫，如果換成自己，又會怎寫。
  多學習=學習人家的發問並解答，學習人家的寫法

  少看=只看不做也枉然

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2012-11-6 16:48 | 只看該作者
本帖最後由 GBKEE 於 2012-11-6 16:51 編輯

回復 5# mark15jill
確實是須如此的,一來可知問題的源故 ,二是可節省論壇資源.

回復 4# kai6929
這只是將目原本. 1#發問要複製在Sheet2.A2的資料,移動到Sheet2.L13
試試看
  1. Option Explicit
  2. Sub check()
  3.     Dim K As String, M As Boolean, xRow As Integer, xi As Integer
  4.     Dim Rng As Range
  5.     With ActiveSheet.Shapes(Application.Caller)
  6.         With .TextFrame
  7.             K = .Characters.Text
  8.             If Left(K, 1) = "■" Then
  9.                 .Characters.Text = "□加工一"
  10.                 M = False
  11.             Else
  12.                 .Characters.Text = "■加工一"
  13.                 M = True
  14.             End If
  15.             .Characters(1, Len(K) + 1).Font.Size = 10
  16.             .Characters(1, 1).Font.Size = 10
  17.         End With
  18.         .TopLeftCell.Offset(, 1) = M
  19.         .TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
  20.     End With
  21.     Sheet2.Range("L13").CurrentRegion.Offset(1).Clear
  22.     Set Rng = Sheet2.Range("L13").CurrentRegion.Rows(1)
  23.     With ActiveSheet
  24.         xRow = 25
  25.         Do While .Cells(xRow, "C") <> ""
  26.             If .Cells(xRow, "C") = 1 Then
  27.                 xi = xi + 1
  28.                 Rng.Copy
  29.                 With Sheet2.Cells(Rows.Count, "L").End(xlUp).Offset(1)
  30.                     .PasteSpecial
  31.                     .Cells(1) = xi                               '項次
  32.                     '資料存放在合併儲存個的第1個Cells
  33.                     .Cells(1, 2) = ActiveSheet.Cells(xRow, "A")  '加工項目
  34.                     .Cells(1, 3) = ActiveSheet.Cells(xRow, "F")  '加工規格
  35.                     .Cells(1, 6) = ActiveSheet.Cells(xRow, "H")  '(單價)
  36.                     .Cells(1, 7) = ActiveSheet.Cells(xRow, "I")  '次數
  37.                     .Cells(1, 8) = ActiveSheet.Cells(xRow, "K")  '加工費用
  38.                 End With
  39.             End If
  40.             xRow = xRow + 1
  41.         Loop
  42.     End With
  43.     Application.CutCopyMode = False
  44. End Sub
複製代碼

TOP

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
5#
發表於 2012-11-6 15:30 | 只看該作者
若相同題目.. 建議以原帖回復發問
1

評分人數

    • GBKEE: 我很贊同金錢 + 1

  多做多想多學習，少看少錯少迷途

  多做=多多練習，多多編寫。
  多想=想想為什麼人家程式要那樣寫，如果換成自己，又會怎寫。
  多學習=學習人家的發問並解答，學習人家的寫法

  少看=只看不做也枉然

TOP

        靜思自在 : 口說一句好話，如口出蓮花；口說一句壞話如口吐毒蛇。
12
返回列表 上一主題