[巨集VBA]初心者學習心得07:cell或range的複製貼上,多個sheet複製貼上到一個sheet,選擇某個資料夾路徑,取得整列的資料到陣列,取得陣列大小,找某個欄位值,去除儲存格裡面的開頭的單引號

2021-06-10

5018
0
2021-06-24

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

巨集VBA

回首頁

kevinya

低調

[巨集VBA]初心者學習心得07:cell或range的複製貼上,多個sheet複製貼上到一個sheet,選擇某個資料夾路徑,取得整列的資料到陣列,取得陣列大小,找某個欄位值,去除儲存格裡面的開頭的單引號

標籤雲