123456
返回列表 上一主題 發帖

[發問] 請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎?

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
41# 跳轉到 »
發表於 2013-8-2 15:07 | 只看該作者
回復 38# stillfish00


哈囉 stillfish00 大大

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

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

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

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

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
42#
發表於 2013-8-15 11:46 | 只看該作者
回復 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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
43#
發表於 2013-8-15 13:15 | 只看該作者
回復 42# happycoccolin
不明白你的意思，
要連表頭貼過去? 複製時一起選就好啦

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

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
44#
發表於 2013-8-15 13:40 | 只看該作者
回復 43# stillfish00


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

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

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

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

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

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

謝謝S大的回覆~~

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
45#
發表於 2013-8-15 15:32 | 只看該作者
回復 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
複製代碼

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
46#
發表於 2013-8-15 15:44 | 只看該作者
本帖最後由 happycoccolin 於 2013-8-15 15:54 編輯

回復 43# stillfish00


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

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

謝謝Stillfish00大大!

TEST_130815.zip (12.98 KB)

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
47#
發表於 2013-8-15 16:11 | 只看該作者
回復 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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
48#
發表於 2013-8-15 17:46 | 只看該作者
本帖最後由 stillfish00 於 2013-8-15 17:49 編輯

回復 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
複製代碼

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
49#
發表於 2013-8-16 10:15 | 只看該作者
回復 48# stillfish00


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

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

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

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

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

謝謝S大的耐心與幫忙

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
50#
發表於 2013-8-16 11:26 | 只看該作者
回復 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
複製代碼

TOP

        靜思自在 : 【停滯不前，終無所得】人都迷於尋找奇蹟，因而停滯不前；縱使時間再多、路再長，也了無用處，終無所得。
123456
返回列表 上一主題