[發問] 是否有辦法框選範圍以值的方式下移不改變儲存格公式??

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

11^#

發表於 2014-3-16 06:03 | 只看該作者

回復 4# luhpro

Sub 往下移動()
Dim lRow&, lRows&
Dim rTar As Range
Set rTar = Selection
If rTar.Count = 1 Then
lRows = 1
Else
lRows = UBound(rTar.Value2, 1)
End If
icol = 7
Do While icol < 16
Range(Cells(rTar.Row, icol), Cells(Rows.Count, icol).End(xlUp)).Copy _
Cells(rTar.Row + lRows, icol)
'Range(Cells(rTar.Row, icol), Cells(rTar.Row + lRows - 1, icol)) = "" ' 不確定你是否要清掉這些資料
icol = icol + 8
Loop
End Sub

複製代碼

大大這一段往下的代碼是否有辦法一次下降2格並增加多欄

像圖中框選的欄位同時下降

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

10^#

發表於 2013-11-27 02:15 | 只看該作者

回復 9# luhpro

感謝你我再試看看.....菜鳥摸索中感恩..............

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 16
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2024-11-14

9^#

發表於 2013-11-26 22:19 | 只看該作者

回復 luhpro
大大我的確是要插入一些資料到目前的資料序列中 ...
a31075ha 發表於 2013-11-26 01:37

依你的需求重寫程式如下:
以下程式放在 Module

Public bOK As Boolean
Public rTar As Range

複製代碼

以下程式放在要插入資料的Sheet

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Set rTar = Target
ufMain.Show
If bOK Then Cancel = True
End Sub

複製代碼

以下程式放在 Module (更名為 ufMain, 建兩個TextBox 分別命名為 tbColG 與 tbColO, 建兩個 Buttom 分別命名為 cbCancel 與 cbOK )

Private Sub cbCancel_Click()
bOK = False
ufMain.Hide
End Sub
Private Sub cbOK_Click()
Dim lRow&, lRows&, lI&
Dim arData
bOK = True
If tbColO.Text = "" Then tbColO.Text = tbColG.Text
With rTar.Parent
icol = 7
arData = Split(tbColG.Text, Chr(13) & Chr(10))
lRows = UBound(arData, 1)
lRow = rTar.Row
.Range(.Cells(lRow, icol), .Cells(Rows.Count, icol).End(xlUp)).Copy .Cells(lRow + lRows + 1, icol)
.Range(.Cells(lRow, icol), .Cells(lRow + lRows, icol)) = ""
.Cells(lRow, icol).Resize(lRows + 1) = Application.Transpose(arData)
icol = 15
arData = Split(tbColO.Text, Chr(13) & Chr(10))
lRows = UBound(arData, 1)
lRow = rTar.Row
.Range(.Cells(lRow, icol), .Cells(Rows.Count, icol).End(xlUp)).Copy .Cells(lRow + lRows + 1, icol)
.Range(.Cells(lRow, icol), .Cells(lRow + lRows, icol)) = ""
.Cells(lRow, icol).Resize(lRows + 1) = Application.Transpose(arData)
With ufMain
.tbColG.Text = ""
.tbColO.Text = ""
.Hide
End With
End With
End Sub

複製代碼

觸發方式為 :
1. 任意 Mark 儲存格並對 Mark 的區域按滑鼠右鍵. (程式只會用到第一個儲存格的列號, 作為插入資料的起始列號)
2. 程式會開一個 UserForm 內含兩個輸入區, 分別用於輸入要插入欄G 與欄O 的資料.
(若要插入的資料不只一筆, 請按 Ctrl+Enter 換列輸入, 每一列視為一筆資料, 兩欄的資料 "筆數" 可以不相等,
若欄O的輸入區未輸入資料, 則會將欄G 的資料 Copy 過去欄O , 即兩欄都會新增相同的資料.)
3. 若按下 "取消" 按紐, UserForm 會關閉, 接著恢復顯示一般 "在儲存格按右鍵" 後會顯示的快捷列 (即仍有保留原先按滑鼠右鍵的功能).
4. 若按下 "確定" 按紐, 會先執行插入資料的作業, 再關閉 UserForm, 且快捷列改為不顯示.

範例程式如下:

MoveVol-a.zip (13.71 KB)

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

8^#

發表於 2013-11-26 01:37 | 只看該作者

回復 6# luhpro

另外, 我倒覺得你要的可能只是:
插入一些資料到目前的資料序列中,
若真是這個需求, 那程式又會與上面不一樣了.
----------------------------------------------
大大我的確是要插入一些資料到目前的資料序列中
只是因為表單里就這二欄式必須自己KEY上去其他都是公式設定好換算
我試過插入列後下拉公式也會跑掉很多也會換算上一列資料跟時間換算..
所以才想有甚麼辦法可以上下移動資料

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

7^#

發表於 2013-11-26 01:10 | 只看該作者

回復 6# luhpro

大大感謝你這樣就很夠用了因為原本想說會是選取範圍整個往下移動所以怕會有資料沒被選到而被覆蓋掉
不過既然整個往下那就不會有這個問題了....往上只要不去動到已經完成的資料所以刪掉空格也解決了這個問題
總之感謝大大解決我的困饒表單用了太多公式函式了 ... = ="

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 16
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2024-11-14

6^#

發表於 2013-11-25 23:40 | 只看該作者

回復 luhpro
不知道是否有辦法像圖中黑色部份一樣下移後不是變成2個5而是將原本的清除掉
而上或 ...
a31075ha 發表於 2013-11-24 22:21

1. 要將原本的資料清除掉, 把上面 4# 所提程式 15. 中的 ' 去掉就是你要的功能了:

Range(Cells(rTar.Row, icol), Cells(rTar.Row + lRows - 1, icol)) = "" ' 不確定你是否要清掉這些資料

2. 而上或下如有資料而不覆蓋<<---以下範例
其中 "上如有資料而不覆蓋",
依下圖所述看起來我猜你要的應該是 :
去掉空白的儲存格.
若是的話, 那此時應該是不需要管使用者到底是 Mark 哪些儲存格,
都只做去掉空白的儲存格這個動作,
以下程式針對 G 與 O 兩欄去掉所有的空白儲存格.

Sub 往上移動()
Dim lRow&, lBRow&, lERow&
Dim rTar As Range
icol = 7
Do While icol < 16
lRow = Cells(5, icol).End(xlDown).Row
lERow = Cells(Rows.Count, icol).End(xlUp).Row
lBRow = Cells(lRow, icol).End(xlDown).Row
Do While lRow <> lERow
Range(Cells(lBRow, icol), Cells(lERow, icol)).Copy Cells(lRow + 1, icol)
Range(Cells(lERow - lBRow + lRow + 2, icol), Cells(lERow, icol)) = ""
lRow = Cells(5, icol).End(xlDown).Row
lERow = Cells(Rows.Count, icol).End(xlUp).Row
lBRow = Cells(lRow, icol).End(xlDown).Row
Loop
icol = icol + 8
Loop
End Sub

複製代碼

不過, "下如有資料而不覆蓋" - 這個可能會有疑慮,
以黑格那欄來看,原先的排列是:

1 2 3 4 空格 5 6 7 8 ~

若我 Mark 3 4 那兩個儲存格的列,
再按往下移動鈕,
那結果到底應該是 :

1 2 空格空格 3 4 空格 5 6 7 8 ~ (3 及其以下全部往下移兩列)

還是

1 2 空格空格 3 5 6 7 8 ~ (3 與 4 往下移兩列, 但 4 所移目的格已有 5 所以不覆蓋, 3 變不見了)

呢?

另外, 我倒覺得你要的可能只是:
插入一些資料到目前的資料序列中,
若真是這個需求, 那程式又會與上面不一樣了.

不知你的需求是哪個?

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

5^#

發表於 2013-11-24 22:21 | 只看該作者

回復 4# luhpro

不知道是否有辦法像圖中黑色部份一樣下移後不是變成2個5而是將原本的清除掉

而上或下如有資料而不覆蓋<<---以下範例

黃色部份是已完成製作的部分綠色部分是正在製作
如果往上移動是否有辦法移動到綠色部分有資料後就不再移動才不會造成把完成的資料覆蓋掉或者變動到.

感謝大大你因改成自帶資料跟公式的表格後才發現常需要更改順序而插入會整個亂掉...= ="

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 16
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2024-11-14

4^#

發表於 2013-11-24 10:37 | 只看該作者

因為報表內含有很多公式及很多voolkup的欄位也有時間計算的格式我試著插入列後下移公式公式會整個亂 ...
a31075ha 發表於 2013-11-23 16:17

a31075ha 說 :
而上或下如有資料而不覆蓋 <=== 這句話不易理解, 希望能舉例一下.
至於往下移動的方式,這裡拋磚引玉一下: (以下程式 Mark 區域不限所選的欄位,只取所作用的列範圍)

Sub 往下移動()
Dim lRow&, lRows&
Dim rTar As Range
Set rTar = Selection
If rTar.Count = 1 Then
lRows = 1
Else
lRows = UBound(rTar.Value2, 1)
End If
icol = 7
Do While icol < 16
Range(Cells(rTar.Row, icol), Cells(Rows.Count, icol).End(xlUp)).Copy _
Cells(rTar.Row + lRows, icol)
'Range(Cells(rTar.Row, icol), Cells(rTar.Row + lRows - 1, icol)) = "" ' 不確定你是否要清掉這些資料
icol = icol + 8
Loop
End Sub

複製代碼

帖子: 39
主題: 8
精華: 0
積分: 53
點名: 0
作業系統: WIN7
軟體版本: 2003
閱讀權限: 20
註冊時間: 2013-11-16
最後登錄: 2016-1-30

3^#

發表於 2013-11-23 16:27 | 只看該作者

回復 2# a31075ha

應該是說框選後只計算要下移的列數而會下移的只有第7跟第15欄有點語無倫次 = ="