[發問] 想將重量搬到相同資料的第一行

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

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

2^#

發表於 2013-11-23 14:13 | 只看該作者

回復 1# joslau
試試看

Option Explicit
Sub Ex()
Dim Rng As Range, E As Range
With ActiveSheet
Set Rng = .Range("C:C").SpecialCells(xlCellTypeBlanks)
For Each E In Rng.Areas
If E.Cells(E.Rows.Count).Row < .Rows.Count Then
E.Cells(1) = E.Cells(E.Rows.Count + 1)
E.Cells(E.Rows.Count + 1) = ""
End If
Next
End With
End Sub

複製代碼

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

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: 7
閱讀權限: 10
註冊時間: 2013-7-22
最後登錄: 2015-7-21

3^#

發表於 2013-11-23 17:42 | 只看該作者

回復 joslau
試試看
GBKEE 發表於 2013-11-23 14:13

謝謝回覆

但如果我以A列做一個範圍
而該範圍是以A12開始

範圍外的上下隔了一行可能會有其他資料

即是紅色部份可能會有其他資料

是改" Set Rng = "那行?

Worksheets("Sheet1").Range("c12").End(xlDown).SpecialCells(xlCellTypeBlanks)

複製代碼

好像起不了作用

應該是怎樣寫?

GBKEE

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

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

4^#

發表於 2013-11-23 18:54 | 只看該作者

本帖最後由 GBKEE 於 2013-11-23 18:57 編輯

回復 3# joslau

Sub Ex()
Dim Rng As Range, E As Range
With ActiveSheet
Set Rng = .Range("C12:C23").SpecialCells(xlCellTypeBlanks)
For Each E In Rng.Areas
If E.Cells(E.Rows.Count).Row < 23 Then
E.Cells(1) = E.Cells(E.Rows.Count + 1)
E.Cells(E.Rows.Count + 1) = ""
End If
Next
End With
End Sub

複製代碼

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

GBKEE

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

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

5^#

發表於 2013-11-24 06:54 | 只看該作者

回復 5# bmouth
你可製作 3# 圖示內容,執行4#的程式碼,試試

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

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

6^#

發表於 2013-11-24 07:28 | 只看該作者

回復 5# bmouth
4# 用滑鼠貼製即可。

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: 7
閱讀權限: 10
註冊時間: 2013-7-22
最後登錄: 2015-7-21

7^#

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

回復 5# GBKEE

謝謝回覆

因每次行數不不樣....正研究中

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: 7
閱讀權限: 10
註冊時間: 2013-7-22
最後登錄: 2015-7-21

8^#

發表於 2013-11-25 20:28 | 只看該作者

本帖最後由 joslau 於 2013-11-25 20:29 編輯

完成!!!!!!

Option Explicit
Sub Ex()
Dim Rng As Range, E As Range, lastrow As Long
With ActiveSheet
lastrow = Worksheets("sheet1").Range("a12").End(xlDown).Row
Set Rng = .Range("a12:L" & lastrow&).SpecialCells(xlCellTypeBlanks)
For Each E In Rng.Areas
If E.Cells(E.Rows.Count).Row < .Rows.Count Then
E.Cells(1) = E.Cells(E.Rows.Count + 1)
E.Cells(E.Rows.Count + 1) = ""
End If
Next
End With
End Sub

複製代碼

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: 7
閱讀權限: 10
註冊時間: 2013-7-22
最後登錄: 2015-7-21

9^#

發表於 2013-12-3 13:10 | 只看該作者

大致完成我需要的東西了
再次多謝GBKEE

Sub autopl()
Dim i As Long
Dim MyString, myLen
For i = 15 To [a65536].End(4).Row
MyString = Cells(i, 2)
If Len(MyString) = 10 Then
Cells(i, 9).FormulaR1C1 = ""
Cells(i, 10).FormulaR1C1 = ""
Cells(i, 11).FormulaR1C1 = ""
End If
Next i
Ex
Ex2
Ex3
Ex4
add1
ctn1
End Sub
Sub Ex()
Dim Rng As Range, E As Range, lastrow3 As Long
With ActiveSheet
lastrow3 = Worksheets("sheet1").Range("a15").End(xlDown).Row
Set Rng = .Range("J15:J" & lastrow3&).SpecialCells(xlCellTypeBlanks)
For Each E In Rng.Areas
If E.Cells(E.Rows.Count).Row < .Rows.Count Then
E.Cells(1) = E.Cells(E.Rows.Count + 1)
E.Cells(E.Rows.Count + 1) = ""
End If
Next
End With
End Sub
Sub Ex2()
Dim Rng2 As Range, D As Range, lastrow2 As Long
With ActiveSheet
lastrow2 = Worksheets("sheet1").Range("a15").End(xlDown).Row
Set Rng2 = .Range("I15:I" & lastrow2&).SpecialCells(xlCellTypeBlanks)
For Each D In Rng2.Areas
If D.Cells(D.Rows.Count).Row < .Rows.Count Then
D.Cells(1) = D.Cells(D.Rows.Count + 1)
D.Cells(D.Rows.Count + 1) = ""
End If
Next
End With
End Sub
Sub Ex3()
Dim Rng3 As Range, f As Range, lastrow5 As Long
With ActiveSheet
lastrow5 = Worksheets("sheet1").Range("a15").End(xlDown).Row
Set Rng3 = .Range("k15:k" & lastrow5&).SpecialCells(xlCellTypeBlanks)
For Each f In Rng3.Areas
If f.Cells(f.Rows.Count).Row < .Rows.Count Then
f.Cells(1) = f.Cells(f.Rows.Count + 1)
f.Cells(f.Rows.Count + 1) = ""
End If
Next
End With
End Sub
Sub Ex4()
Dim rw As Long
For rw = 15 To [a65536].End(4).Row
If Cells(rw, 2).Value = 1 Then Cells(rw, 2).EntireRow.Delete
Next rw
End Sub
Sub add1()
Dim l As Long
For l = 15 To [a65536].End(4).Row
If Cells(l, 2) <> "" Then
Cells(l, 2).FormulaR1C1 = ""
End If
Next l
End Sub
Sub ctn1()
Dim lastrow4 As Long
With ActiveSheet
lastrow4 = Worksheets("sheet1").Range("a15").End(xlDown).Row
Range("b15").FormulaR1C1 = "0"
Range("b16").FormulaR1C1 = "=IF(RC[7]="""",R[-1]C,R[-1]C+1)"
Range("b16").AutoFill Destination:=Range("b16:b" & lastrow4)
End With
End Sub

複製代碼

Hsieh

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

10^#

發表於 2013-12-3 14:15 | 只看該作者

回復 9# joslau

Sub ex()
Dim A As Range, B As Range, Rng As Range
With Sheet1
Set Rng = .Range("A:A").Find("DATA1", lookat:=xlWhole) '找A欄標題列位置
If Not Rng Is Nothing Then
If Application.Count(Rng.CurrentRegion.Columns(3)) > 0 Then '資料C欄數值數量判斷
For Each A In Rng.CurrentRegion.Columns(3).SpecialCells(xlCellTypeConstants, 1) '每個數值做迴圈
Set B = Rng.CurrentRegion.Columns(2).Find(A.Offset(, -2), lookat:=xlWhole) '找到B欄第一個位置
If Not B Is Nothing Then A.Cut B.Offset(, 1) '移動位置
Next
End If
End If
End With
End Sub

複製代碼

學海無涯_不恥下問