[發問] excel工作表合併的問題-另插入前面兩行加入特定欄位資料於AB欄中 (已解決)

sax868

繼先前有個好用的程式後,有個新的問題想請各位大大幫忙:

如附件想把工作表1,2,3 合併成總表, 除了在原本的資料外要另插入前面兩行加入特定欄位資料於AB欄中
以便將model name 跟model#依序列出, 請問厲害的大大們指令要怎麼寫呀? (不然我有300工作表, 用複製貼上,插入兩欄,複製貼上...每個禮拜都要花6小時用這很笨的方法...眼睛都快花了...)

感激不盡!!^^

excel工作表合併的問題
« 於: 2009-05-22, 15:08:29 »  

--------------------------------------------------------------------------------
一個excel有3 個工作表
表一如下
A B C D E F
1張三 1000 500 200 400 300
2李四 200 400 100 200 150
3王五 4000 200 300 500 100
4張六 200 500 600 400 200

表二如下
A B C D E F
1張三 25 30 40 15 20
2李四 40 20 15 30 15
3王五 15 20 35 40 20
4張六 40 30 51 20 50


表三如下
A B C D E F
1張三 100 50 200 400 300
2李四 200 400 10 200 150
3王五 40 2 300 500 100
4張六 200 50 60 400 20
如何把表一的A1(張3)下二欄自動插入表二和表三張三的數據
表一的 (李四)下二欄插入表二和表三李四的數據,
表一的(王五)下二欄插入表二和表三王五的數據,
以此類推
因為我的表格有幾百欄如果 一個一個複製太慢了
有人可以教我嗎
不過因為我操作上的關係
可否有人幫我用函數表示
謝謝

Re: excel工作表合併的問題
GBKEE « 回覆文章 #1 於: 2009-05-23, 11:47:52 »

xu123
新增合併資料的工作表 命名為"總表" 試試看

程式碼:
Sub Ex()
　　Dim AR(), R As Range, C%, S%, Sh As Worksheet
　　For Each Sh In Sheets
　　　　If Sh.Name <> "總表" Then
　　　　　　With Sh
　　　　　　　　If S = 0 Then
　　　　　　　　　　ReDim Preserve AR(S)
　　　　　　　　　　AR(S) = .Range(.Range("A1"), .Range("A1").End(xlToRight))
　　　　　　　　　　C = .Range(.Range("A1"), .Range("A1").End(xlToRight)).Columns.Count
　　　　　　　　End If
　　　　　　　　For Each R In .Range(.[A2], .[a65536].End(xlUp))
　　　　　　　　　　S = S + 1
　　　　　　　　　　ReDim Preserve AR(S)
　　　　　　　　　　AR(S) = R.Resize(1, C)
　　　　　　　　Next
　　　　　　End With
　　　　End If
　　Next
　　With Sheets("總表")
　　　　.UsedRange = ""
　　　　.[A1].Resize(UBound(AR) + 1, C) = Application.Transpose(Application.Transpose(AR))
　　　　.Activate
　　　　.UsedRange.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
　　End With
End Sub

GBKEE

回復 1# sax868
每一程序是依個案的需求來撰寫的.

1. Sub Ex()
   
2.     Dim R%, S%, Sh As Worksheet
   
3.     With Sheets("總表")
   
4.         .UsedRange.Offset(1).Clear
   
5.         R = 1
   
6.         For Each Sh In Sheets
   
7.             If Sh.Name <> "總表" Then
   
8.                     Sh.[a7].CurrentRegion.Copy .Cells(R, "C")
   
9.                     S = .Cells(Rows.Count, "C").End(xlUp).Row
   
10.                     .Cells(R + 1, "A").Resize(S - R, 2) = Application.WorksheetFunction.Transpose(Sh.[c2:c3].Value)
    
11.                     R = S + 1
    
12.             End If
    
13.         Next
    
14.     End With
    
15. End Sub

複製代碼

sax868

回復 2# GBKEE

   
感激不盡~千言萬語也道不盡小學生的感激!!突然如釋重負般地掉下淚來!終於不用每週再被那個很笨的方法耍六小時了!!
感謝版主的大力幫忙!!晚安!!