使用VBA从非活动工作表复制指定列至Excel表的技术需求

Hey there! I’ve put together a complete VBA solution that handles exactly what you need—exporting the Name, Student Id, and Term columns from all non-active sheets in your workbook into a new, clean Excel file. Here’s how to implement it:

This code is designed to be assigned to the button on your Overview sheet. It will automatically skip the active Overview sheet, locate the required columns in all other sheets, and compile the data into a new workbook.

Full Code Implementation #

Sub ExportStudentData()
    Dim sourceWB As Workbook
    Dim newWB As Workbook
    Dim sourceWS As Worksheet
    Dim newWS As Worksheet
    Dim lastRow As Long
    Dim nameCol As Integer, idCol As Integer, termCol As Integer
    Dim destRow As Long
    Dim savePath As String
    
    ' Set reference to your current workbook
    Set sourceWB = ThisWorkbook
    ' Create a blank new workbook
    Set newWB = Workbooks.Add
    Set newWS = newWB.Sheets(1)
    newWS.Name = "Combined Student Data"
    
    ' Set up headers in the new sheet
    newWS.Cells(1, 1).Value = "Name"
    newWS.Cells(1, 2).Value = "Student Id"
    newWS.Cells(1, 3).Value = "Term"
    destRow = 2 ' Start pasting data below headers
    
    ' Loop through every sheet in your workbook
    For Each sourceWS In sourceWB.Sheets
        ' Skip the active sheet (Overview, since you'll run this from there)
        If sourceWS.Name <> sourceWB.ActiveSheet.Name Then
            On Error Resume Next
            ' Find column positions for each required field (case-insensitive)
            nameCol = sourceWS.Rows(1).Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
            idCol = sourceWS.Rows(1).Find(What:="Student Id", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
            termCol = sourceWS.Rows(1).Find(What:="Term", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
            On Error GoTo 0
            
            ' Only proceed if all three columns are found
            If nameCol <> 0 And idCol <> 0 And termCol <> 0 Then
                ' Get the last row with data in the source sheet
                lastRow = sourceWS.Cells(sourceWS.Rows.Count, nameCol).End(xlUp).Row
                
                ' Copy each column's data to the new sheet
                sourceWS.Range(sourceWS.Cells(2, nameCol), sourceWS.Cells(lastRow, nameCol)).Copy _
                    Destination:=newWS.Cells(destRow, 1)
                sourceWS.Range(sourceWS.Cells(2, idCol), sourceWS.Cells(lastRow, idCol)).Copy _
                    Destination:=newWS.Cells(destRow, 2)
                sourceWS.Range(sourceWS.Cells(2, termCol), sourceWS.Cells(lastRow, termCol)).Copy _
                    Destination:=newWS.Cells(destRow, 3)
                
                ' Update the next row to paste data from the next sheet
                destRow = newWS.Cells(newWS.Rows.Count, 1).End(xlUp).Row + 1
            Else
                ' Optional: Alert if columns are missing in a sheet
                MsgBox "Warning: Required columns not found in sheet '" & sourceWS.Name & "'", vbExclamation
            End If
        End If
    Next sourceWS
    
    ' Clean up the new sheet
    newWS.Columns("A:C").AutoFit
    
    ' Set save location (adjust this to your preferred folder)
    savePath = Environ("USERPROFILE") & "\Documents\Student_Data_Export_" & Format(Now(), "YYYY-MM-DD_HH-MM-SS") & ".xlsx"
    
    ' Save and notify
    newWB.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    MsgBox "Data exported successfully to:" & vbCrLf & savePath, vbInformation
    
    ' Clean up memory
    Set newWS = Nothing
    Set newWB = Nothing
    Set sourceWS = Nothing
    Set sourceWB = Nothing
End Sub

Step-by-Step Setup #

1. Open your workbook and go to the Overview sheet.
2. Right-click your export button and select Assign Macro.
3. Click New to open the VBA editor, then paste the code above.
4. Save your workbook as a Macro-Enabled Workbook (.xlsm extension) so the macro stays with it.

Key Features #

• Auto-Skip Active Sheet: Ignores the Overview sheet so it doesn’t process your button/instructions sheet.
• Flexible Column Detection: Finds the required columns no matter where they’re placed in the source sheets.
• Error Handling: Warns you if any sheet is missing one or more required columns instead of crashing.
• Combined Data: All student records from non-active sheets are appended into a single organized sheet.
• Timestamped Save: Exports to your Documents folder with a unique timestamp to avoid overwriting previous files.

Optional: Separate Sheets for Each Intake/Source #

If you want each source sheet’s data in its own tab in the new workbook, replace the loop section with this code:

' Loop through every sheet in your workbook
For Each sourceWS In sourceWB.Sheets
    If sourceWS.Name <> sourceWB.ActiveSheet.Name Then
        On Error Resume Next
        nameCol = sourceWS.Rows(1).Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
        idCol = sourceWS.Rows(1).Find(What:="Student Id", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
        termCol = sourceWS.Rows(1).Find(What:="Term", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
        On Error GoTo 0
        
        If nameCol <> 0 And idCol <> 0 And termCol <> 0 Then
            ' Add a new sheet for the current source
            Set newWS = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count))
            newWS.Name = sourceWS.Name
            
            ' Add headers
            newWS.Cells(1, 1).Value = "Name"
            newWS.Cells(1, 2).Value = "Student Id"
            newWS.Cells(1, 3).Value = "Term"
            
            ' Copy data
            lastRow = sourceWS.Cells(sourceWS.Rows.Count, nameCol).End(xlUp).Row
            sourceWS.Range(sourceWS.Cells(2, nameCol), sourceWS.Cells(lastRow, nameCol)).Copy Destination:=newWS.Cells(2, 1)
            sourceWS.Range(sourceWS.Cells(2, idCol), sourceWS.Cells(lastRow, idCol)).Copy Destination:=newWS.Cells(2, 2)
            sourceWS.Range(sourceWS.Cells(2, termCol), sourceWS.Cells(lastRow, termCol)).Copy Destination:=newWS.Cells(2, 3)
            
            newWS.Columns("A:C").AutoFit
        Else
            MsgBox "Warning: Required columns not found in sheet '" & sourceWS.Name & "'", vbExclamation
        End If
    End If
Next sourceWS

' Delete the default blank sheet if we added new tabs
If newWB.Sheets.Count > 1 Then
    Application.DisplayAlerts = False
    newWB.Sheets("Sheet1").Delete
    Application.DisplayAlerts = True
End If

Test the macro with a copy of your workbook first to make sure it works as expected!

内容的提问来源于stack exchange，提问作者Nimy Alex