y663258

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2010-5-18 20:31 | 只看該作者

列増減

報表列數可否依來源資料増減，謝謝協助。

複製 -9801010630co2.rar (119.18 KB)

樓主熱帖

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

11^#

發表於 2010-5-25 12:04 | 只看該作者

經更改 Ar(26) = Val(Mid(Ar(24), 1, 2))可以符合需求，以上謝謝二位版主。

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

10^#

發表於 2010-5-21 19:43 | 只看該作者

HSIEH兄
Ar(24) = mystr(UBound(mystr)): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0),
Ar(26)要改取Ar(24) = mystr(UBound(mystr)): 的左起2位,如23045取23謝謝指導

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

9^#

發表於 2010-5-21 11:49 | 只看該作者

回復 8# y663258

超過Y欄的數量要自動增減會有困難
光是表頭就要重繪
其餘問題請參考

Sub Ex()
Dim A As Range, Ar(31), Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet1
For Each A In .Range(.[P2], .[P65536].End(xlUp))
If A.Offset <> "" Then
If d(A.Value) = "" Then
d(A.Value) = A.Offset(, 1)
Else
d(A.Value) = d(A.Value) & "," & A.Offset(, 1)
End If
End If
Next
End With
For Each ky In d.keys
mystr = Split(d(ky), ",")
Ar(0) = "第一期" & ky: Ar(1) = "95-013-4-001": Ar(3) = "大型"
For i = 0 To UBound(mystr)
Ar(i + 4) = mystr(i)
Next
If d(ky) <> "" Then
Ar(24) = mystr(UBound(mystr)): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0), 1, 2)
Ar(28) = Mid(mystr(0), 1, 2) * 2: Ar(29) = 373.5: Ar(30) = Ar(28) * Ar(29) / 100000
End If
ReDim Preserve Ay(x)
Ay(x) = Ar
x = x + 1
Erase Ar
Next
Sheet2.[B5:Ay65536] = ""
Sheet2.[B5].Resize(x, 31) = Application.Transpose(Application.Transpose(Ay))
End Sub

複製代碼

學海無涯_不恥下問

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

8^#

發表於 2010-5-21 00:09 | 只看該作者

Hsieh 版主謝謝經測試完全正確,不好意識我在附檔中把sheet2 z5即程式瑪ar(24)誤值為該列第一位,正確

chm.rar (28.01 KB) 是最大值,其餘需求如附檔說明，敬請協助再此感恩。

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

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

7^#

發表於 2010-5-19 22:41 | 只看該作者

回復 5# y663258

不知樓主是不是這個意思

Sub Ex()
Dim A As Range, Ar(31), Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet1
For Each A In .Range(.[P2], .[P65536].End(xlUp))
If A.Offset <> "" Then
If d(A.Value) = "" Then
d(A.Value) = A.Offset(, 1)
Else
d(A.Value) = d(A.Value) & "," & A.Offset(, 1)
End If
End If
Next
End With
For Each ky In d.keys
mystr = Split(d(ky), ",")
Ar(0) = ky: Ar(1) = "95-013-4-001": Ar(3) = "大型"
For i = 0 To UBound(mystr)
Ar(i + 4) = mystr(i)
Next
If d(ky) <> "" Then
Ar(24) = Mid(mystr(0), 1, 2): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0), 1, 2)
Ar(28) = Mid(mystr(0), 1, 2) * 2: Ar(29) = 373.5: Ar(30) = Ar(28) * Ar(29) / 100000
End If
ReDim Preserve Ay(x)
Ay(x) = Ar
x = x + 1
Erase Ar
Next
Sheet2.[C5:Ay65536] = ""
Sheet2.[B5].Resize(x, 31) = Application.Transpose(Application.Transpose(Ay))
End Sub

複製代碼

學海無涯_不恥下問

TOP

Min

　暱稱: 閔

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 172
主題: 39
精華: 20
積分: 177
點名: 0
作業系統: Microsoft Windows XP
軟體版本: Microsoft Office 2003
閱讀權限: 100
性別: 男
來自: 高雄
註冊時間: 2010-5-1
最後登錄: 2023-3-19

論壇貢獻勳章帥哥勳章

6^#

發表於 2010-5-19 21:25 | 只看該作者

PD961A 謝謝示教經測試與我想要結果有不同，可能是我表達不好再說明Sheet1!O2:O35565(每次數量不一樣)COPY至 ...
y663258 發表於 2010/5/19 05:46 PM

大概是這樣子! 其他的用錄製因該都可以辦的到...

Sub test()
Dim lS1RowEnd As Long
Dim lS2RowEnd As Long

lS1RowEnd = Worksheets("Sheet1").Range("Q65536").End(xlUp).Row
lS2RowEnd = Worksheets("Sheet2").Range("B5").End(xlDown).Row + 1

Worksheets("Sheet2").Rows(lS2RowEnd & ":" & lS1RowEnd + lS2RowEnd - 2).Insert Shift:=xlDown

Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(2, 17), Worksheets("Sheet1").Cells(lS1RowEnd, 17)).Copy Worksheets("Sheet2").Cells(lS2RowEnd, 2)
End Sub

複製 -9801010630co2.rar (97.1 KB)

若是我回答，使您滿意，請您讓我知道！
若是我的回覆，您仍有其他見解，也請您不嗇指教！

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

5^#

發表於 2010-5-19 17:46 | 只看該作者

PD961A 謝謝示教經測試與我想要結果有不同，可能是我表達不好再說明Sheet1!O2:O35565(每次數量不一樣)COPY至Sheet2!B5，向下貼上並増減列與Sheet1!O2:O35565有資料列數同，再將C5:AY5 公式同時向下貼上。

TOP

PD961A

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 1180
主題: 204
精華: 0
積分: 1051
點名: 0
作業系統: Mac.OS10.6
軟體版本: Office 2003
閱讀權限: 100
性別: 男
註冊時間: 2010-5-3
最後登錄: 2012-9-19

2012龍年全勤獎章論壇貢獻勳章終身榮譽會員勳章好學求知勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2010-5-19 13:52 | 只看該作者

本帖最後由 PD961A 於 2010-5-19 16:33 編輯

回復 3# y663258

引用夏板主定義名稱
http://forum.twbts.com/viewthread.php?tid=251&extra=page%3D1
改成 A=OFFSET(Sheet1!$O$2,,,COUNTA(Sheet1!$O$2 : $O$25),3)
   N=OFFSET(sheet2!$B$5,COUNTA(Sheet2!$B$5 : $B$65536),)

Sub Macro1()
[A].Copy [N]'複製到
[A].ClearContents'清除
End Sub

另直接到閔版主給的網址下載111的檔案修正亦可:http://forum.twbts.com/viewthread.php?tid=251&extra=page%3D1

TOP

y663258

中學生 Rank: 2

帖子: 52
主題: 13
精華: 0
積分: 119
點名: 0
作業系統: xp
軟體版本: OFFICE 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-6
最後登錄: 2022-6-7

3^#

發表於 2010-5-19 10:11 | 只看該作者

謝謝MIN版主
上去看了文章還是一知半解，無法自己解決問題，可否做個實列讓我加速學習?謝謝

TOP

列増減

列増減

樓主熱帖

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]