excel vba 轉置貼上後 依照特定儲存格另存新檔

想請問...
(1)有一總表(如圖:總表) 原本是橫向排列(內容有包含分割儲存格與合併儲存格)
(2)想把表單整理成直向(如圖:篩選後另存新檔(高雄、台中、台北))
(3)將表單依照篩選條件(如高雄、台中、台北)存檔,如圖:資料夾


不知道有沒有巨集可以使用? 有參考一些巨集 但是遇到有合併的儲存格與轉置貼上的時候就出現失敗

謝謝大家
檔案連結

Sub Macro1()
Dim rLastCell As Range
Dim strName As String
Dim lLoop As Long
Dim wbNew As Workbook
Dim cnt As Integer
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], _
SearchDirection:=xlPrevious)

For lLoop = 2 To rLastCell.Row
cnt = WorksheetFunction.CountIf(Range("c:c"), Range("c" & lLoop))
Set wbNew = Workbooks.Add

.Range("1:2," & lLoop & ":" & lLoop + cnt - 1).EntireRow.Copy
.vbnew.Sheets(1).Range ("A1")
.Range.PasteSpecial Transpose:=Ture
Range(Selection, Selection.End(xlToRight)).Select


Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Rows.AutoFit
Selection.Columns.AutoFit
wbNew.Close SaveChanges:=True, Filename:=ThisWorkbook.Path _
& Application.PathSeparator & .Cells(lLoop, 3) & ".xlsx"
lLoop = lLoop + cnt - 1
Next lLoop
End With
End Sub




excel vba 轉置貼上後 依照特定儲存格另存新檔
excel vba 轉置貼上後 依照特定儲存格另存新檔
excel vba 轉置貼上後 依照特定儲存格另存新檔
excel vba 轉置貼上後 依照特定儲存格另存新檔
excel vba 轉置貼上後 依照特定儲存格另存新檔
樓主方便把檔案放上來嗎?(如果資料有機密性,內容可以修改一下再上傳)......這樣方便版上的大大們直接取用處理(VBA有貼了,但資料得大大們花點時間自己打?)。

當然,沒有應該也OK啦,我想還是會有熱心的大大出手的。(不過可以的話,還是盡量讓大家方便一點?)

您考慮一下?
Der,misser1
ktll wrote:
想請問...(1)有(恕刪)


Range("1:2," & lLoop & ":" & lLoop + cnt - 1).EntireRow.Copy

這一句,Range的引數有分隔 "1:2 , 3:5"(舉例),所以出現錯誤:無法在不相鄰的範圍執行此命令。

或者可以分成2步驟處理?

其他好像也有問題,再看看是否有檔案可下載測試囉。(不然就麻煩您再稍等看看,其他大大可能會直接幫您修改成符合需求的結果)
Der,misser1
篩選vba,可直接套用這篇
https://www.mobile01.com/topicdetail.php?f=511&t=5056987&p=1#63233105

請自行修改部份條件
一、總表保留,篩選欄位c欄
二、用if跳過,當Name_Data(變數)=分公司,不分類
三、.UsedRange.Copy Sheets("_" & Name_Data & "_").Cells(1, 1)
改成以下3行

.UsedRange.Copy
Sheets("_" & Name_Data & "_").Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Sheets("_" & Name_Data & "_").Cells.EntireColumn.AutoFit

四、工作表另存新檔,範例很多,請google

補充:
五、漏看了一列,篩選時,需多加一條件,其中一行修正如下

.Range(Col & ":" & Col).AutoFilter Field:=1, Criteria1:=Name_Data, Operator:=xlOr, Criteria2:="=分公司"
ktll wrote:
附上檔案如下,麻煩了(恕刪)


樓主,您的檔案打開,直接執行,會發生錯誤訊息(溢位.....)

我到一般工作視窗(一開始作用工作表是最後一個,台北),把目前作用工作表(錯字修正........)換到[總表],再跑一遍您的程式,是可以跑完的喔。(新檔案也存完了)

您再試試。(或者您就用S大提供的,感覺是比較「保險」一點啦,哈)
Der,misser1
misser wrote:
樓主,您的檔案打開,(恕刪)


但其實它裡面複製的不完全,第一列跟第二列沒有複製
我是參考別人的製作的,但因為遇到有合併的儲存格就無法順利複製 ....另外也沒有轉置貼上

因為自己也不太會VBA,所以很困擾
ktll wrote:
但其實它裡面複製的不(恕刪)


是的(看得出來)。

S大有提供VBA內容給您囉,這樣還不夠OK嗎?~~

您研究看看S大的內容,嘗試親手做做看啊~~如果不行,可以再說喔,看看是否找時間來幫您完成。
Der,misser1
謝謝大家
目前比較趕 有先用別的方式做了 後續會來研究S大提供的方法~

misser wrote:
是的(看得出來)。S(恕刪)
ktll wrote:
目前比較趕 有先用別的方式做了(恕刪)


既然做好了,那就有時間學習別的方式


另一種方式請參考

Sub test()

Dim temparray() As Variant, All_Criteria, Name_Data, i As Integer, Col As String, New_book As Workbook, Report As String, ttt As Double

Col = "c"

Application.ScreenUpdating = False

With Sheets("總表")
.Range(Col & ":" & Col).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Set All_Criteria = .Range(Col & "2", .Range(Col & Rows.Count).End(xlUp)).SpecialCells(12)
ReDim temparray(1 To All_Criteria.Count)

For Each Name_Data In All_Criteria
i = i + 1: temparray(i) = Name_Data
Next

For Each Name_Data In temparray
ttt = Timer
DoEvents
If Name_Data <> "分公司" Then
.Range(Col & ":" & Col).AutoFilter Field:=1, Criteria1:=Name_Data, Operator:=xlOr, Criteria2:="=分公司"
.UsedRange.Copy

Set New_book = Workbooks.Add
New_book.Sheets(1).Name = Name_Data
'xlPasteAll、xlPasteAllUsingSourceTheme
New_book.Sheets(Name_Data).Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Transpose:=True
New_book.Sheets(Name_Data).Cells.EntireColumn.AutoFit
New_book.Sheets(Name_Data).Cells(1, 1).Select
New_book.SaveAs (ThisWorkbook.Path & "\(" & Format(Now(), "yyyymmdd hhmmss") & ")" & Name_Data), xlOpenXMLWorkbook
New_book.Close 1

Set New_book = Nothing
Report = Report & Name_Data & ":" & Timer - ttt & "秒" & vbNewLine

End If
Next

.AutoFilterMode = False

End With
Application.ScreenUpdating = True

MsgBox Report
Shell "explorer.exe" & " " & ThisWorkbook.Path, vbNormalFocus


End Sub

文章分享
評分
評分
複製連結

今日熱門文章 網友點擊推薦!