VBA 宏 excel 导出第一行的列 header 当前数据

Question

如何导出第一行中存在数据 (header) 的所有列？

在此示例图像中，我只想导出 "FOO" 列：

这是我的代码；

Sub Worksheets_to_txt() 

    Dim ws As Worksheet
    Dim relativePath As String
    Dim answer As VbMsgBoxResult

    relativePath = ActiveWorkbook.Path

    answer = MsgBox("Export in TXT?", vbYesNo, "Run Macro")    
    If answer = vbYes Then

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In ActiveWorkbook.Worksheets

        ws.Select
        ws.Copy
        ActiveWorkbook.SaveAs Filename:= _
        relativePath & "\" & ws.Name & ".txt", _
        FileFormat:=xlText, CreateBackup:=False
        ActiveWorkbook.Close
        ActiveWorkbook.Activate
    Next
     End If

End Sub

谢谢

Answer 1

请替换您的这部分代码：

    For Each ws In ActiveWorkbook.Worksheets

        ws.Select
        ws.Copy
        ActiveWorkbook.SaveAs Filename:= _
        relativePath & "\" & ws.Name & ".txt", _
        FileFormat:=xlText, CreateBackup:=False
        ActiveWorkbook.Close
        ActiveWorkbook.Activate
    Next

这个：

   Dim rngDel As Range, lastCol As Long, wsNew As Worksheet, HDRow As Long, i As Long
   For Each ws In ActiveWorkbook.Worksheets
     if ws.Range("A1").value <> "" then
        ws.Copy
        Set wsNew = ActiveWorkbook.Sheets(1)
        'search for the header row:
        For i = 1 To 100
            If WorksheetFunction.CountA(wsNew.rows(i)) > 0 Then
                HDRow = i: Exit For
            End If
        Next i
        lastCol = wsNew.cells(HDRow, wsNew.Columns.count).End(xlToLeft).Column
        'place all cells from the first row, without headers, in a Union range
        For i = 1 To lastCol
            If wsNew.cells(HDRow, i).value = "" Then
                If rngDel Is Nothing Then
                    Set rngDel = wsNew.cells(HDRow, i)
                Else
                    Set rngDel = Union(rngDel, wsNew.cells(HDRow, i))
                End If
            End If
        Next i
        'delete the columns without header, if any:
        If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
        Set rngDel = Nothing 'preparing the range for the next sheet use
        ActiveWorkbook.saveas fileName:= _
                relativePath & "\" & ws.Name & ".txt", _
                FileFormat:=xlText, CreateBackup:=False
        ActiveWorkbook.Close
        ActiveWorkbook.Activate
    End If
  Next
End Sub

它将没有 header 的第一行单元格放在一个范围内，并在保存工作簿之前立即删除该范围内的整列。

Answer 2

这是我对这个问题的看法。我没有删除列，而是将它们收集在 ExportRange 中并将其复制到新文件。

Option Explicit

' Info: Method loops over all worksheets in current Workbook
' and looks for headers with name "Foo". Every column with
' Foo name is exported to the text file with the name of
' that worksheet.

Public Sub Export()

    Dim DataSource As Worksheet
    For Each DataSource In ThisWorkbook.Worksheets

        If DataSource.Range("A1").Value = vbNullString Then
            GoTo NextItem
        End If
    
        Dim Header As Range: Set Header = DataSource.Rows(1).Find("Foo")
        If Header Is Nothing Then GoTo NextItem
        
        ' Understanding where Find method starts is essential
        ' to prevent looping back to the beginning using FindNext method.
        Dim StartAddress As String: StartAddress = Header.Address
        Dim ExportRange As Range
        Set ExportRange = GetColumnData(DataSource, Header.Columns)

        Set Header = DataSource.Rows(1).FindNext(Header)
        Do Until (Header Is Nothing) Or (Header.Address = StartAddress)
            Set ExportRange = Union(ExportRange, GetColumnData(DataSource, Header.Columns))
            Set Header = DataSource.Rows(1).FindNext(Header)
        Loop
        
        ExportRangeToText ExportRange, ThisWorkbook.Path & "\" & DataSource.Name
        
NextItem:
    Next DataSource

End Sub


Private Function GetColumnData(ByVal DataSource As Worksheet, ByVal DataColumn As Range) As Range
        
    Dim LastRow As Long
    LastRow = DataSource.Cells(DataSource.Rows.Count, DataColumn.Column).End(xlUp).Row
    Set GetColumnData = DataColumn.Resize(LastRow, 1)
    
End Function


Private Sub ExportRangeToText(ByVal Rng As Range, ByVal Filename As String)
    
    Dim Export As Workbook: Set Export = Application.Workbooks.Add
    Rng.Copy Export.Worksheets(1).Range("A1")
    Export.SaveAs Filename:=Filename & ".txt", _
                  FileFormat:=xlText, CreateBackup:=False
    Export.Close
    
End Sub

VBA 宏 excel 导出第一行的列 header 当前数据

VBA macro excel export colums with first row header present data

excel

vba

multiple-columns