返回列表 上一主題 發帖

有錄製巨集但要寫成迴圈還是摸不到邊

opman

帖子
12 
主題
4 
精華
0 
積分
57 
點名
0  
作業系統
W7 
軟體版本
EX2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2014-11-6 
最後登錄
2018-8-30 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2015-1-27 11:53 | 只看該作者

有錄製巨集但要寫成迴圈還是摸不到邊

本帖最後由 GBKEE 於 2015-2-2 15:28 編輯

社團數高達120個
學生人數固定40
希望可以將學生名單和成績整理到總表。
希望有大大可以幫忙。相關資料如附件。

Book1.rar (17.21 KB)

收藏 分享

opman

帖子
12 
主題
4 
精華
0 
積分
57 
點名
0  
作業系統
W7 
軟體版本
EX2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2014-11-6 
最後登錄
2018-8-30 
5#
發表於 2015-2-2 20:50 | 只看該作者
回復 4# 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兔年全勤獎章
4#
發表於 2015-2-2 16:11 | 只看該作者
回復 3# opman
  1. Option Explicit
  2. Sub 整理()
  3.     Dim iCols%, i%, iRows&
  4.     Dim Rng As Range
  5.     Sheets("總表").UsedRange.Clear
  6.     iRows = Sheets("學生名單").UsedRange.Rows.Count '標頭 + 學生人數
  7.     iCols = Sheets("成績").UsedRange.Columns.Count  '社團數
  8.     For i = 2 To iCols
  9.         Set Rng = Sheets("總表").Cells(Sheets("總表").Rows.Count, "a").End(xlUp)
  10.         '往下貼的位置
  11.         With Rng.Offset(IIf(Rng.Row = 1, 0, 1)).Resize(iRows)
  12.             .Cells = Sheets("學生名單").Columns(1).Value       '第一欄:學生名單
  13.             .Offset(, 1) = Sheets("學生名單").Columns(i).Value '第二欄:學生名稱
  14.             .Offset(, 2) = Sheets("成績").Columns(i).Value     '第三欄:學生成績
  15.         End With
  16.     Next
  17. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

opman

帖子
12 
主題
4 
精華
0 
積分
57 
點名
0  
作業系統
W7 
軟體版本
EX2010 
閱讀權限
20 
性別
男 
來自
台南市 
註冊時間
2014-11-6 
最後登錄
2018-8-30 
3#
發表於 2015-2-1 20:02 | 只看該作者
回復 2# luhpro


    感謝大大，但我是想接續貼下去。要如何改

Book1-A.zip (41.4 KB)

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 2015-1-30 22:40 | 只看該作者
社團數高達120個
學生人數固定40
希望可以將學生名單和成績整理到總表。
希望有大大可以幫忙。相關資料如 ...
opman 發表於 2015-1-27 11:53
  1. Sub 整理()
  2.   Dim iCol%, iCols%
  3.   Dim lRows1&, lRows2&, lRowsT&, lRow&
  4.   Dim shS1 As Worksheet, shS2 As Worksheet, shST As Worksheet
  5.   
  6.   Set shS1 = Sheets("學生名單")
  7.   Set shS2 = Sheets("成績")
  8.   Set shS3 = Sheets("總表")
  9.   shS3.Cells.Clear
  10.   With shS1
  11.     .[A1].Resize(.Cells(Rows.Count, 1).End(xlUp).Row).Copy shS3.[A1]
  12.     iCols = shS1.Cells(1, Columns.Count).End(xlToLeft).Column
  13.     For iCol = 2 To iCols
  14.       .Cells(1, iCol).Resize(41).Copy shS3.Cells(1, (iCol - 1) * 2)
  15.       shS2.Cells(1, iCol).Resize(41).Copy shS3.Cells(1, (iCol - 1) * 2 + 1)
  16.     Next
  17.   End With
  18. End Sub
複製代碼
Book1-A.zip (62.14 KB)

TOP

        靜思自在 : 人事的艱難與琢磨，就是一種考驗。
返回列表 上一主題