cell或range的複製貼上,多個sheet複製貼上到一個sheet,選擇某個資料夾路徑,取得整列的資料到陣列,取得陣列大小,找某個欄位值,去除儲存格裡面的開頭的單引號
cell或range的複製貼上(Range貼到Range,Cell貼到Cell)
Sub CopyPasteTest()
'開啟來源檔案
Dim wkbSource As Workbook
Dim strSourceFileToOpen As String
strSourceFileToOpen = ""
'透過dialog視窗取得檔案名稱
strSourceFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 MPS BILLING 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strSourceFileToOpen = "False" Then
MsgBox "選取 MPS BILLING 的檔案失敗!.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbSource = Workbooks.Open(strSourceFileToOpen)
wkbSource.Activate
End If
Dim intActiveSheetNoInSourceFile As Integer
intActiveSheetNoInSourceFile = 1
Dim wsSource As Worksheet
Set wsSource = wkbSource.Sheets(intActiveSheetNoInSourceFile)
'source檔案找到 對照值 的欄位
'關掉畫面上的資料的更新:
'執行巨集之前,先把畫面更新關掉,可以比較快速跑完巨集,不過資料量不大
'的時候,也沒必要就是了,記得程式碼的最後要把他再打開
Application.ScreenUpdating = False
'#如要一口氣複製多個儲存格的話,請善用Range物件,就可以做到整個區塊的複製貼上
'1.只要複製格式的話,利用.PasteSpecial Paste:=xlPasteFormats
wsSource.Range(Cells(1, FindColumn(wsSource, "productno").Column), Cells(GetLastRowByColumnName(wsSource, "productno"), FindColumn(wsSource, "productno").Column)).Copy
wsSource.Range(Cells(1, FindColumn(wsSource, "customerno").Column), Cells(GetLastRowByColumnName(wsSource, "productno"), FindColumn(wsSource, "customerno").Column)).PasteSpecial Paste:=xlPasteFormats
'2.只要複製value的話,利用.PasteSpecial Paste:=xlPasteValues
wsSource.Range(Cells(2, FindColumn(wsSource, "productno").Column), Cells(GetLastRowByColumnName(wsSource, "productno"), FindColumn(wsSource, "productno").Column)).Copy
wsSource.Range(Cells(2, FindColumn(wsSource, "salesamt").Column), Cells(GetLastRowByColumnName(wsSource, "productno"), FindColumn(wsSource, "salesamt").Column)).PasteSpecial Paste:=xlPasteValues
'#若是只要複製貼上單一儲存格,請參考如下
'1.只複製格式
wsSource.Cells(1, FindColumn(wsSource, "productno").Column).Copy
wsSource.Cells(1, FindColumn(wsSource, "customerno").Column).PasteSpecial Paste:=xlPasteFormats
'1.只複製value
wsSource.Cells(1, FindColumn(wsSource, "productno").Column).Copy
wsSource.Cells(1, FindColumn(wsSource, "customerno").Column).PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = True
MsgBox "複製貼上作業順利完成!"
End Sub
'尋找某個欄位
Function FindColumn(ws As Worksheet, strColumnName As String) As Range
Dim FoundColumn As Range
Set FindColumn = ws.Rows("1:1").Find(strColumnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Function
'取得最後一列lastrow
Function GetLastRowByRange(ws As Worksheet, rangeColumn As Range) As Long
Dim longLastRow As Long
longLastRow = ws.Cells(Rows.Count, rangeColumn.Column).End(xlUp).Row
GetLastRowByRange = longLastRow
End Function
'取得最後一列lastrow
Function GetLastRowByColumnName(ws As Worksheet, strColumnName As String) As Long
Dim longLastRow As Long
longLastRow = ws.Cells(Rows.Count, FindColumn(ws, strColumnName).Column).End(xlUp).Row
GetLastRowByColumnName = longLastRow
End Function
完整範例下載:
https://drive.google.com/drive/folders/1FjiT8bb_FCGL09vmyZkCJ0KODYFkMfrL?usp=sharing
多個sheet複製貼上到一個sheet + 選擇某個資料夾路徑:
下面範例是把某個資料夾下面所有的excel檔的第一個sheet都複製到另一個新的excel的第一個sheet,因此新的excel的第一個sheet的資料就是多個Excel的資料的合併。
Sub 複製貼上()
'選擇大量excel所在的路徑
Dim folder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "請選擇要合併的excel的所在資料夾"
If .Show = -1 Then ' if OK is pressed
folder = .SelectedItems(1)
Else
MsgBox "選取 資料夾 失敗!.", vbExclamation, "Sorry!"
Exit Sub
End If
End With
Application.ScreenUpdating = False
Dim wbTot As Workbook
Dim wsTot As Worksheet
'取得路徑內所有的檔案
Dim loopFileName As String
loopFileName = Dir(folder & "\")
If Len(loopFileName) = 0 Then
MsgBox " 該資料夾內無任何檔案! "
Exit Sub
End If
Dim fileCreated As Boolean
fileCreated = False
Dim lastRowOfTot As Long
lastRowOfTot = 0
Do While Len(loopFileName) > 0
'Debug.Print loopFileName
'只開啟.xlsx, .xls
If LCase(Right(loopFileName, 5)) = ".xlsx" Or LCase(Right(loopFileName, 4)) = ".xls" Then
If fileCreated = False Then
'新增一個Excel
Set wbTot = Workbooks.Add
fileCreated = True
Set wsTot = wbTot.Worksheets(1)
'從第一列開始複製貼上
lastRowOfTot = lastRowOfTot + 1
End If
Dim wkbSource As Workbook
Dim strSourceFile As String
strSourceFile = ""
Set wkbSource = Workbooks.Open(folder & "\" & loopFileName)
Dim wsSource As Worksheet
Set wsSource = wkbSource.Worksheets(1)
Dim lastRowOfSourceFile As Long
lastRowOfSourceFile = GetLastRow(wsSource)
Dim lastColumnOfSourceFile As Long
lastColumnOfSourceFile = wsSource.Cells(1, Columns.Count).End(xlToLeft).Column
'1.複製貼上格式,利用.PasteSpecial Paste:=xlPasteFormats
wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowOfSourceFile, lastColumnOfSourceFile)).Copy
wsTot.Range(wsTot.Cells(lastRowOfTot, 1), wsTot.Cells(lastRowOfTot + lastRowOfSourceFile - 1, _
lastColumnOfSourceFile)).PasteSpecial Paste:=xlPasteFormats
'2.複製貼上value,利用.PasteSpecial Paste:=xlPasteValues
wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowOfSourceFile, lastColumnOfSourceFile)).Copy
wsTot.Range(wsTot.Cells(lastRowOfTot, 1), wsTot.Cells(lastRowOfTot + lastRowOfSourceFile - 1, _
lastColumnOfSourceFile)).PasteSpecial Paste:=xlPasteValues
lastRowOfTot = lastRowOfTot + lastRowOfSourceFile
'自動關閉多個excel檔
wkbSource.Activate
wsSource.Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
End If
loopFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "複製貼上成功!.", vbExclamation, "Success!"
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
'刪除空白的列
Sub DeleteBlankRows(ws As Worksheet, lastRow As Long)
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.UsedRange
rows = r.rows.Count
For i = rows To (lastRow + 10) Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
'尋找某個欄位
Function FindColumn(ws As Worksheet, strColumnName As String) As Range
Dim FoundColumn As Range
Set FindColumn = ws.rows("1:1").Find(strColumnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Function
'取得最後一列lastrow
Function GetLastRow(ws As Worksheet) As Long
Dim longLastRow As Long
longLastRow = ws.Cells(rows.Count, 1).End(xlUp).Row
GetLastRow = longLastRow
End Function
選擇某個資料夾路徑:
Dim folder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "請選擇要合併的excel的所在資料夾"
If .Show = -1 Then ' if OK is pressed
folder = .SelectedItems(1)
Else
MsgBox "選取 資料夾 失敗!.", vbExclamation, "Sorry!"
Exit Sub
End If
End With
取得整列的資料到陣列:以下範例是取得整列的header資料到陣列
Dim wkbTot As Workbook
Dim strTotFileToOpen As String
Dim strTotFilePath As String
strTotFileToOpen = ""
'透過dialog視窗取得檔案名稱
strTotFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 總表檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strTotFileToOpen = "False" Then
MsgBox "選取 總表檔案 失敗!.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbTot = Workbooks.Open(strTotFileToOpen)
End If
Dim wsTot As Worksheet
Set wsTot = wkbTot.Sheets(1)
'取消篩選
If wsTot.FilterMode Then wsTot.ShowAllData
If wsTot.AutoFilterMode Then wsTot.AutoFilterMode = False
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
Dim headings() As Variant
headings = Application.Index(wsTot.Range("A1", "Q1").Value, 1, 0)
取得陣列大小:
Dim arr(1 To 3) As String ' Array starting at 1 instead of 0: nightmare fuel
Debug.Print ArrayLen(arr) ' Prints 3. Everything's going to be ok.
Public Function ArrayLen(arr As Variant) As Integer
ArrayLen = UBound(arr) - LBound(arr) + 1
End Function
找某個欄位值:
Dim wkbSource As Workbook
Set wkbSource = Workbooks.Open("myFileName.xlsx")
Dim wsSource As Worksheet
Set wsSource = wkbSource.Worksheets(1)
If wsSource.FilterMode Then wsSource.ShowAllData
If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
wsSource.Activate
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
Dim POCell As Range
wsSource.Columns("A:Z").Select
Set POCell = Selection.Find(What:="PO Review Date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
去除儲存格裡面的開頭的單引號:
Dim wkbTemplate As Workbook
Dim strTemplateFileToOpen As String
strTemplateFileToOpen = ""
'透過dialog視窗取得檔案名稱
strTemplateFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 excel 檔", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strTemplateFileToOpen = "False" Then
MsgBox "選取 excel 檔 失敗!.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbTemplate = Workbooks.Open(strTemplateFileToOpen)
End If
Dim wsTemplate As Worksheet
Set wsTemplate = wkbTemplate.Worksheets(1)
If wsTemplate.FilterMode Then wsTemplate.ShowAllData
If wsTemplate.AutoFilterMode Then wsTemplate.AutoFilterMode = False
ActiveSheet.Outline.ShowLevels ColumnLevels:=2 '解除群組
wsTemplate.Cells(1, 5).Value = wsTemplate.Cells(1, 5).Value '去除單引號
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 '恢復群組
參考資料:
自己工作經驗
VBA Select Folder with msoFileDialogFolderPicker - wellsr.com
VBA - Collecting all the heading names into an array
excel - Get length of array? - Stack Overflow
How to find a value in an excel column by vba code Cells.Find - Stack Overflow
VBA Remove hidden quotes in one cell | MrExcel Message Board