功能描述：?

一個(gè)Excel文件有很多個(gè) 樣式相同 的數(shù)據(jù)表，

需要將多張數(shù)據(jù)表的內(nèi)容合并到一張數(shù)據(jù)表里。

vba實(shí)現(xiàn)代碼如下：

Attribute VB_Name = "NewMacros"
Option Explicit
Public Const Const_OutSheetName As String = "VBA匯總"
Public Const Const_PZSheetName As String = "配置"

Sub 匯總()
Attribute 匯總.VB_Description = "宏由 LiuZW 錄制，時(shí)間: 2023/08/19"
Attribute 匯總.VB_ProcData.VB_Invoke_Func = " 14"
'
' 匯總 Macro
' 宏由 LiuZW 錄制，時(shí)間: 2023/08/19
'

'

    Dim i, j, k As Integer
        
    
    '創(chuàng)建“配置”數(shù)據(jù)表并提示用戶填寫配置
    Dim isExistPZ As Boolean
    isExistPZ = False
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_PZSheetName Then
            isExistPZ = True
            Exit For
        End If
    Next
    
    '定義表示要復(fù)制的區(qū)域的變量
    Dim mRow1, mColumn1, mRow2, mColumn2 As Integer
        
    If isExistPZ Then
        mRow1 = Application.Worksheets(Const_PZSheetName).Range("B2").Value
        mRow2 = Application.Worksheets(Const_PZSheetName).Range("B3").Value
        mColumn1 = Application.Worksheets(Const_PZSheetName).Range("B4").Value
        mColumn2 = Application.Worksheets(Const_PZSheetName).Range("B5").Value
       
       If mRow1 = 0 Or mRow2 = 0 Or mColumn1 = 0 Or mColumn2 = 0 Then
       
            '提示用戶填寫
            MsgBox ("請(qǐng)?zhí)顚懪渲脭?shù)據(jù)表后運(yùn)行。")
            Exit Sub
       End If
       
       '配置的填寫有效性判斷
       If Not IsNumeric(mRow1) Or Not IsNumeric(mRow2) Or Not IsNumeric(mColumn1) Or Not IsNumeric(mColumn2) Then
            MsgBox ("配置數(shù)據(jù)表中鍵入的區(qū)域表述無(wú)效，請(qǐng)鍵入數(shù)字格式的行列號(hào)。")
            Exit Sub
       End If
       
    
    Else
        '創(chuàng)建“配置”數(shù)據(jù)表
        Sheets.Add
        ActiveSheet.name = Const_PZSheetName
        
        '填寫基礎(chǔ)信息
        Application.Worksheets(Const_PZSheetName).Range("A1").Value = "不需要匯總的數(shù)據(jù)表名稱"
        Application.Worksheets(Const_PZSheetName).Range("B1").Value = Const_PZSheetName
        Application.Worksheets(Const_PZSheetName).Range("C1").Value = Const_OutSheetName
        Application.Worksheets(Const_PZSheetName).Range("A2").Value = "復(fù)制區(qū)域的起始行"
        Application.Worksheets(Const_PZSheetName).Range("A3").Value = "復(fù)制區(qū)域的終止行"
        Application.Worksheets(Const_PZSheetName).Range("A4").Value = "復(fù)制區(qū)域的起始列"
        Application.Worksheets(Const_PZSheetName).Range("A5").Value = "復(fù)制區(qū)域的終止列"
        
        '提示用戶填寫
        MsgBox ("請(qǐng)?zhí)顚懪渲脭?shù)據(jù)表后運(yùn)行。")
        Exit Sub
    End If
    
    '判斷是否已有“VBA匯總”數(shù)據(jù)表
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_OutSheetName Then
            MsgBox ("要生成的數(shù)據(jù)表“" + Const_OutSheetName + "”存在同名數(shù)據(jù)表，請(qǐng)修改或刪除同名數(shù)據(jù)表后重試。")
            Exit Sub
        End If
    Next
    
    '創(chuàng)建“VBA匯總”數(shù)據(jù)表
    Sheets.Add
    ActiveSheet.name = Const_OutSheetName
    Columns("A:A").Select
    Selection.NumberFormatLocal = "@"
      
    '復(fù)制各個(gè)數(shù)據(jù)表的數(shù)據(jù)并粘貼到匯總表
    For i = 1 To Worksheets.Count
        Dim mSheetName As String
        mSheetName = Worksheets(i).name
        
        '判斷當(dāng)前數(shù)據(jù)表是否為 無(wú)需匯總的數(shù)據(jù)表
        'MsgBox ("當(dāng)前數(shù)據(jù)表的第一行一共有" + CStr(Application.CountA(Sheets(Const_PZSheetName).Rows(1))) + "個(gè)數(shù)據(jù)")
        
        '定義當(dāng)前數(shù)據(jù)表是否為 無(wú)需匯總的數(shù)據(jù)表 的標(biāo)記，True表示無(wú)需匯總，F(xiàn)alse表示需要匯總
        Dim mKey As Boolean
        mKey = False
        
        For j = 2 To Application.CountA(Sheets(Const_PZSheetName).Rows(1))
            If mSheetName = Sheets(Const_PZSheetName).Cells(1, j) Then
                'MsgBox ("當(dāng)前數(shù)據(jù)表“" + mSheetName + "”是不需要匯總的數(shù)據(jù)表")
                mKey = True
                Exit For
            End If
        Next
        
        '如果當(dāng)前數(shù)據(jù)表不是 無(wú)需匯總的數(shù)據(jù)表，就執(zhí)行匯總
        If mKey = False Then
        
            '執(zhí)行復(fù)制和粘貼
            
            
            
            Application.Worksheets(mSheetName).Activate
            Application.Worksheets(mSheetName).Range(Cells(mRow1, mColumn1), Cells(mRow2, mColumn2)).Select
            Selection.Copy
            
            '判斷要粘貼的位置并粘貼
            Application.Worksheets(Const_OutSheetName).Activate
            Dim usableRowCount As Integer
            usableRowCount = Application.Application.Sheets(Const_OutSheetName).Range("b65536").End(xlUp).Row + 2
            Application.Worksheets(Const_OutSheetName).Cells(usableRowCount, 2).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
            
            '填充第一列
            For k = 0 To mRow2 - mRow1
                Application.Worksheets(Const_OutSheetName).Cells(usableRowCount + k, 1).Value = mSheetName
            Next
            
        End If
    Next
End Sub

?文件鏈接：數(shù)據(jù)表合并.bas

下載后直接在excel 查看代碼處導(dǎo)入文件即可。文章來(lái)源地址http://www.zghlxwxcb.cn/news/detail-665350.html

到了這里，關(guān)于excel vba 將多張數(shù)據(jù)表的內(nèi)容合并到一張數(shù)據(jù)表的文章就介紹完了。如果您還想了解更多內(nèi)容，請(qǐng)?jiān)谟疑辖撬阉鱐OY模板網(wǎng)以前的文章或繼續(xù)瀏覽下面的相關(guān)文章，希望大家以后多多支持TOY模板網(wǎng)！