happycoccolin

回復 38# stillfish00


哈囉 stillfish00 大大

謝謝您的耐心溝通與協助!
成功了!!!!!放煙火~

也謝謝在這版幫助過我的版大與版友們

真的很感激大家的耐心解惑

也希望有朝一日我也能成為幫助人的角色

happycoccolin

回復 40# stillfish00


    S大~不好意思想請教一下~如何將資料填入表頭呢?

我現在需要用到將某份資料轉檔,就差表頭名稱及欄位不同,也不用比對

我使用最笨的方法錄製巨集 但是表頭資料不知如何輸入~可以幫忙看看嗎~謝謝

Sub Macro1()
'
' Macro1 Macro
'

'
    Rows("1:1").Select
    ActiveSheet.Paste
    Range("B6").Select
    Workbooks.Open Filename:="C:\Users\Documents\VB\2\A_0814.xlsx"
    Range("A6:A50000").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Book2").Activate
    ActiveWindow.SmallScroll Down:=-3
    Range("B2").Select
    ActiveSheet.Paste
    Windows("A_0814.xlsx").Activate
    Range("B6:B50000").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Book2").Activate
    Range("D2").Select
    ActiveSheet.Paste
End Sub

stillfish00

回復 42# happycoccolin
不明白你的意思，
要連表頭貼過去? 複製時一起選就好啦

能否上傳檔案再說明清點?

happycoccolin

回復 43# stillfish00


    S大~~~我有另開一個提問~在以下路徑~

http://forum.twbts.com/thread-10164-1-1.html

因為目前需要將一個檔案中 特定幾欄的資料取出(不用比對) 並產生一新檔案填入特定欄位

兩個檔案的表頭及欄位是不同的

而且目前A.xlsx是不固定的 需要由User自行選擇載入

有試著用之前的檔案修改 但是語法不純熟尚在學習中 所以想請教S大~~~

謝謝S大的回覆~~

stillfish00

回復 44# happycoccolin

1. Sub TEST()
   
2.   Dim ar, r As Long, i As Long
   
3.   Dim cIndexOld, cIndexNew, arNewHeader
   
4.   Dim f
   
5.   
   
6.   cIndexOld = Array(2, 3, 4, 5, 7, 8)   'A檔案中要搬動的欄
   
7.   cIndexNew = Array(2, 4, 21, 24, 43, 44)   '搬到B檔位置(欄號)
   
8.   arNewHeader = Array("W", "R", "X", "B", "JJ", "KK") 'B檔標題名稱
   
9.   
   
10.   f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
    
11.   If Not TypeName(f) = "String" Then Exit Sub '取消則結束
    
12.   
    
13.   Application.ScreenUpdating = False
    
14.   With Workbooks.Open(f)
    
15.     With .Sheets(1)
    
16.       ar = .Range("A5:H" & .[A5].CurrentRegion.Rows.Count).Value
    
17.     End With
    
18.     .Close False
    
19.   End With
    
20.   Application.ScreenUpdating = True
    
21.   
    
22.   r = UBound(ar)
    
23.   With Workbooks.Add
    
24.     With .Sheets(1)
    
25.       For i = LBound(cIndexOld) To UBound(cIndexOld)
    
26.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
    
27.         .Cells(1, cIndexNew(i)).Value = arNewHeader(i)
    
28.       Next
    
29.     End With
    
30.    
    
31.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
    
32.       f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
    
33.       If Not TypeName(f) = "String" Then Exit Sub '取消則結束
    
34.       .SaveAs f, FileFormat:=xlWorkbookDefault
    
35.     End If
    
36.   End With
    
37. End Sub

複製代碼

happycoccolin

回復 43# stillfish00


    S大~若有的檔案是B5欄開始有的是B6欄開始 可以怎麼判斷?

還有若是新表格所有欄位都要有TITLE 可以都填上嗎~

謝謝Stillfish00大大!

happycoccolin

回復 45# stillfish00


    S大~~~可以再請教一下這一段是在描述甚麼動作嗎~

Application.ScreenUpdating = False
  With Workbooks.Open(f)  這應該是指新開的資料檔嗎?
    With .Sheets(1)
      ar = .Range("A5:H" & .[A5].CurrentRegion.Rows.Count).Value 這句不懂甚麼意思
    End With
    .Close False
  End With
  Application.ScreenUpdating = True
  
  r = UBound(ar)
  With Workbooks.Add
    With .Sheets(1)
      For i = LBound(cIndexOld) To UBound(cIndexOld)
        .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
        .Cells(1, cIndexNew(i)).Value = arNewHeader(i)
      Next
    End With

stillfish00

回復 46# happycoccolin

若有的檔案是B5欄開始有的是B6欄開始 可以怎麼判斷?

不知道，
而且你的A_0814.xlsx檔案挺怪的！
[A4]儲存格明明沒文字(也沒有不可見字元)，卻又不是空白儲存格(尋找>特殊目標>空白，不會找到)
用Ctrl+上下也都會跳過。
第一次遇到這種情形~

若是新表格所有欄位都要有TITLE 可以都填上嗎~

改一下

1.   arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填上全部新標題名稱

複製代碼

還有這邊

1.     With .Sheets(1)
   
2.       For i = LBound(cIndexOld) To UBound(cIndexOld)
   
3.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
   
4.       Next
   
5.       .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
   
6.     End With

複製代碼

happycoccolin

回復 48# stillfish00


    哈囉S大~我試過了~~~感激不盡~

想請問一下若是我要跑資料從B5開始的 是要修改哪邊呢?

還是可以用判斷TITLE這種方式處理嗎?

EX:若TITLE(B4)是"Item"就從下一格(B5)開始取資料 一類的

不好意思..又以一般人的想法來提問~@@

謝謝S大的耐心與幫忙

stillfish00

回復 49# happycoccolin

1. Sub TEST()
   
2.   Dim ar, r As Long, i As Long
   
3.   Dim cIndexOld, cIndexNew, arNewHeader
   
4.   Dim f, findTitle
   
5.   
   
6.   cIndexOld = Array(2, 3, 4, 5, 7, 8)   'A檔案中要搬動的欄
   
7.   cIndexNew = Array(2, 4, 21, 24, 43, 44)   '搬到B檔位置
   
8.   arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填全部B檔標題名稱
   
9.   
   
10.   f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
    
11.   If Not TypeName(f) = "String" Then Exit Sub '取消則結束
    
12.   
    
13.   Application.ScreenUpdating = False
    
14.   With Workbooks.Open(f)
    
15.     With .Sheets(1)
    
16.       Set findTitle = .Cells.Find("Item", , xlValues, xlWhole, xlByRows, xlNext)  '找標題 Item
    
17.       If findTitle Is Nothing Then MsgBox "找不到標題": Exit Sub
    
18.       
    
19.       With findTitle.CurrentRegion
    
20.         ar = .Parent.Range(findTitle, .Cells(.Rows.Count, .Columns.Count)).Value
    
21.       End With
    
22.     End With
    
23.     .Close False
    
24.   End With
    
25.   Application.ScreenUpdating = True
    
26.   
    
27.   r = UBound(ar)
    
28.   With Workbooks.Add
    
29.     With .Sheets(1)
    
30.       For i = LBound(cIndexOld) To UBound(cIndexOld)
    
31.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
    
32.       Next
    
33.       .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
    
34.     End With
    
35.    
    
36.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
    
37.       f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
    
38.       If Not TypeName(f) = "String" Then Exit Sub '取消則結束
    
39.       .SaveAs f, FileFormat:=xlWorkbookDefault
    
40.     End If
    
41.   End With
    
42. End Sub

複製代碼