#excel #vba
Вопрос:
Я новичок в VBA, поэтому заранее приношу свои извинения. Я пытаюсь завершить операцию, и я был бы очень признателен за некоторую помощь или вклад.
С помощью макроса я пытаюсь скопировать определенный столбец из всех файлов excel(.xls), который был сохранен в определенной папке и добавлен в текстовый файл .существует условие, например, выбор столбца должен основываться на имени столбца, так как номер столбца варьируется для каждого excel.
Может ли кто-нибудь, пожалуйста, сообщить мне, как создать скрипт с этими условиями
Ответ №1:
Столбцы Стека
- Это позволит скопировать значения столбцов в новую (целевую) книгу и сохранить книгу в той же папке, что и папка книги, содержащей этот код (
Thisworkbook). Новая книга названа в честь заголовка (Name.csv). - Улучшением было бы записать значения в структуру данных (массив, словарь или список массивов), а затем записать их значения в текстовый файл за один раз, даже не имея целевой книги.
- Отрегулируйте значения в разделе константы.
Option Explicit Sub StackColumns() ' Needs 'RefWorksheet', 'RefFirstOccurrenceInRow' and 'RefColumnDataRange' Const ProcTitle As String = "Stack Columns" ' Source Const sFolderPath As String = "C:Test" Const sFilePattern As String = "*.xls*" Const swsName As String = "Sheet1" Const sHeader As String = "Name" Const shRow As Long = 1 ' Destination Dim dFolderPath As String: dFolderPath = ThisWorkbook.Path amp; "" Dim dBaseName As String: dBaseName = sHeader Dim sFileName As String: sFileName = Dir(sFolderPath amp; sFilePattern) If Len(sFileName) = 0 Then MsgBox "No files found.", vbCritical, ProcTitle Exit Sub End If Dim swb As Workbook Dim sws As Worksheet Dim shCell As Range ' Header Cell Dim scdtrg As Range ' Column Data Range (no headers) Dim dwb As Workbook Dim dws As Worksheet Dim dCell As Range Dim IsDestinationWorkbookAdded As Boolean Application.ScreenUpdating = False Do Until Len(sFileName) = 0 Set swb = Workbooks.Open(sFolderPath amp; sFileName) Set sws = RefWorksheet(swb, swsName) If Not sws Is Nothing Then ' worksheet found Set shCell = RefFirstOccurrenceInRow(sws.Rows(shRow), sHeader) If Not shCell Is Nothing Then ' header found Set scdtrg = RefColumnDataRange(shCell) If Not scdtrg Is Nothing Then ' found data in Column Data Range If Not IsDestinationWorkbookAdded Then ' not yet added Set dwb = Workbooks.Add(xlWBATWorksheet) Set dws = Worksheets(1) Set dCell = dws.Range("A1") IsDestinationWorkbookAdded = True 'Else ' already added End If dCell.Resize(scdtrg.Rows.Count).Value = scdtrg.Value Set dCell = dCell.Offset(scdtrg.Rows.Count) Set scdtrg = Nothing 'Else ' no data in Column Data Range End If Set shCell = Nothing 'Else ' header not found End If Set sws = Nothing 'Else ' worksheet not found End If swb.Close False sFileName = Dir Loop If Not dwb Is Nothing Then Application.DisplayAlerts = False ' overwrite without confirmation dwb.SaveAs dFolderPath amp; dBaseName amp; ".csv", xlCSV Application.DisplayAlerts = True 'dwb.FollowHyperlink dFolderPath ' explore the Destination Path 'dwb.Close End If Application.ScreenUpdating = True MsgBox "Columns stacked.", vbInformation, ProcTitle End Sub Function RefWorksheet( _ ByVal wb As Workbook, _ ByVal WorksheetName As String) _ As Worksheet On Error Resume Next Set RefWorksheet = wb.Worksheets(WorksheetName) On Error GoTo 0 End Function Function RefFirstOccurrenceInRow( _ ByVal RowRange As Range, _ ByVal SearchString As String) _ As Range On Error GoTo ClearError With RowRange.Rows(1) Set RefFirstOccurrenceInRow _ = .Find(SearchString, .Cells(.Cells.Count), xlFormulas, xlWhole) End With ProcExit: Exit Function ClearError: Resume ProcExit End Function Function RefColumnDataRange( _ ByVal HeaderCell As Range) _ As Range On Error GoTo ClearError With HeaderCell.Cells(1) With .Resize(.Worksheet.Rows.Count - .Row).Offset(1) Dim lCell As Range Set lCell = .Find("*", , xlFormulas, , , xlPrevious) Set RefColumnDataRange = .Resize(lCell.Row - .Row 1) End With End With ProcExit: Exit Function ClearError: Resume ProcExit End Function