Экспортируйте лист из книги в файл CSV в одном и том же месте каждую неделю
У меня есть лист в книге, который я хотел бы экспортировать в файл CSV, который обновляется каждую неделю. Поэтому в идеале я хочу, чтобы код VBA экспортировал все данные, находящиеся на листе, и перезаписывал то, что существовало на пути. Диапазон данных от A до AJ. Путь к папке будет «C:\Users\HS».
Я пытался адаптировать код @VBasic2008 в расположенном ниже месте, но безрезультатно.
EXCEL-VBA Как экспортировать в CSV... пользовательский диапазон столбцов?
Результат отображается/мигает на экране, когда я его запускаю, но не сохраняется в указанном месте.
Вот именно то, что у меня было:
Option Explicit
Sub ExportColumnsToCSV()
Const sfRow As Long = 1
Const sColsList As String = "A:AJ"
Const dFirst As String = "A1"
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim sws As Worksheet: Set sws = ActiveSheet
Dim swb As Workbook: Set swb = sws.Parent
Dim srrg As Range
Dim slCell As Range
Dim srCount As Long
With sws.Rows(sfRow)
Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If slCell Is Nothing Then
MsgBox "No data in worksheet.", vbCritical, "Export to CSV"
Exit Sub
End If
srCount = slCell.Row - .Row + 1
Set srrg = .Resize(srCount)
End With
Dim srg As Range
Dim n As Long
For n = 0 To UBound(sCols)
If srg Is Nothing Then
Set srg = Intersect(srrg, sws.Columns(sCols(n)))
Else
Set srg = Union(srg, Intersect(srrg, sws.Columns(sCols(n))))
End If
Next n
Dim dwb As Workbook: Set dwb = Application.Workbooks.Add
srg.Copy
dwb.Worksheets(1).Range(dFirst).PasteSpecial xlPasteValues
Dim dFolderPath As String: dFolderPath = swb.Path & "C:\Users\HS"
On Error Resume Next
MkDir dFolderPath
On Error GoTo 0
Dim dFilePath As String
dFilePath = dFolderPath _
& Left(swb.Name, InStrRev(swb.Name, ".") - 1) & ".csv"
' Optionally, out-comment previous line and uncomment next one
' to save with the current worksheet name.
'dFilePath = dFolderPath & sws.Name & ".csv"
Application.DisplayAlerts = False
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSVUTF8, Local:=False
dwb.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Спасибо HS
1. Я только что попробовал, и создается новая книга со всеми данными ячеек. 2.Когда точка останова удалена, она просто мигает в книге, а затем исчезает. Спасибо
Когда вы достигнете точки останова, вам также следует навести указатель мыши на dFilePath, чтобы проверить значение.
Ответы 3
Надеюсь, это поможет, я думаю, что изменения в комментариях должны работать для вашего приложения.
Sub ExportColumnsToCSV()
Dim rngTheRangeYouWant As Range
Set rngTheRangeYouWant = Application.ActiveSheet.Range("$A:$AJ")
Dim lBottomRow As Long
On Error Resume Next
lBottomRow = rngTheRangeYouWant.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
If lBottomRow <= 1 Then
' This assumes there is no data but still has coulmn headers.
MsgBox "there is only 1 row of data here"
Else
Set rngTheRangeYouWant = Application.ActiveSheet.Range("$A$1:$AJ$" & lBottomRow)
With rngTheRangeYouWant
Dim oNewWorkbook As Workbook
Set oNewWorkbook = Application.Workbooks.Add
rngTheRangeYouWant.Copy
With oNewWorkbook
.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
'Change this to your path with extension like
.SaveAs Filename: = "C:\Users\yourPath\ThisFile.csv", FileFormat:=xlCSVUTF8, Local:=False
.Close
Application.DisplayAlerts = True
End With
End With
End If
Set rngTheRangeYouWant = Nothing
Set oNewWorkbook = Nothing
End Sub
Пожалуйста, отметьте мой ответ как ответ, если он вам подходит, спасибо! Удачи!
Спасибо за ответ. Я получаю сообщение MsgBox «здесь только 1 строка данных», когда запускаю его. Данные на листе занимают 18 строк от A до AJ с заголовками.
Я изменил свой ответ после исходного сообщения. Я понял, что моя логическая операция для нижнего ряда была неправильной, попробуйте еще раз, должно быть, если lBottomRow <= 1 перед моим исправлением. У меня было меньше, чем неправильно, например >=
1. Отлично сработало! Файл был создан и сохранен по указанному пути на локальном компьютере. 2. Я попытался сохранить его в SharePoint, но это не сработало. 3. Кроме того, не могли бы вы добавить к нему код, позволяющий экспортировать этот VBA, например, каждую неделю? Спасибо
Извините, вам нужно будет быть более конкретным, рассказать мне об этом, чтобы я мог понять, как вы видите это действие. Предвидите ли вы, что это будет своего рода событие нажатия кнопки, когда оно будет обрабатывать информацию после того, как вы нажмете кнопку, или это будет какой-то таймер, который будет периодически проверять и использовать соглашения об именовании дат, чтобы узнать, сохранили ли вы уже файл на сегодня, как вы видите, что это работает?
Вы можете создать рабочий лист с открытой проверкой сегодняшней даты, если сегодня пятница, спросив пользователя, хотят ли они сохранить данные. При выполнении сравнения if для проверки наличия файла в структуре папок
Извините за поздний ответ. Кнопка не будет нажата. В идеале я бы хотел, чтобы это был таймер, который будет использовать преобразование именования дат или, возможно, обновлять и перезаписывать экспортированный лист, например, через каждые 200 часов. Спасибо
Извините за задержку с ответом, поэтому я предполагаю, что вы понимаете, что я имею в виду, когда говорю, что этот код принадлежит коду книги, но да, это войдет в код книги для события открытия книги.
Option Explicit
Private Sub Workbook_Open()
Dim TodayIsTheDay As Boolean
TodayIsTheDay = IsTodayTheDay
If TodayIsTheDay Then
ExportColumnsToCSV
End If
End Sub
Private Property Get IsTodayTheDay() As Boolean
If Weekday(Date, vbMonday) = 5 Then IsTodayTheDay = True
End Property
Private Sub ExportColumnsToCSV()
Dim rngTheRangeYouWant As Range
Set rngTheRangeYouWant = Application.ActiveSheet.Range("$A:$AJ")
Dim lBottomRow As Long
On Error Resume Next
lBottomRow = rngTheRangeYouWant.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
If lBottomRow <= 1 Then
' This assumes there is no data but still has coulmn headers.
MsgBox "there is only 1 row of data here"
Else
Set rngTheRangeYouWant = Application.ActiveSheet.Range("$A$1:$AJ$" & lBottomRow)
With rngTheRangeYouWant
Dim oNewWorkbook As Workbook
Set oNewWorkbook = Application.Workbooks.Add
rngTheRangeYouWant.Copy
With oNewWorkbook
.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
' If you want to make the name dynamic to the date then do it like this
Dim DatedFileName As String ' I Broke it up this way so you can make the filename dynamic as well
DatedFileName = Format(Date, "yyyymmdd") & "_" & "SomeGenericName" & ".csv"
'Change this to your path with extension like
.SaveAs Filename: = "C:\Users\bwing\OneDrive\Desktop\New folder\" & DatedFileName, FileFormat:=xlCSVUTF8, Local:=False
.Close
Application.DisplayAlerts = True
End With
End With
End If
Set rngTheRangeYouWant = Nothing
Set oNewWorkbook = Nothing
End Sub
Мне было весело с этим, лол, если вы не можете сказать это с моими соглашениями об именах переменных, после прочтения сообщения я вижу, что мне не удалось реализовать путь к файлу, который вы назвали, но я думаю, что сделал это довольно просто
Не нужно извиняться за задержку. И тип файла довольно прост. Я собираюсь протестировать его и оставить отзыв в ближайшее время. Спасибо вам за помощь.
Я также подумал, может быть, установить событие закрытия книги вместо открытия, чтобы оно сохранялось после изменений, также вам не нужно было создавать дополнительную переменную в модуле событий, он мог бы просто сказать, если IsTodayTheDay, то ExportColumnsToCSV, если это не так. Это не имеет смысла, я могу опубликовать новый код, и если вы не понимаете код, который я настроил для его запуска по пятницам, измените 'Weekday(Date, vbMonday) = 5' на любой день, в который вы хотите изменить день, в который он сохраняется.
Если я хорошо понял, я не думаю, что событие закрытия книги необходимо с момента оригинала. исходная книга всегда будет сохраняться теми, кто вносит изменения.
пожалуйста, когда у вас будет возможность, не могли бы вы опубликовать новый код, который экспортирует столбцы в CSV для определенного листа в книге. Я не упомянул, что в рабочей тетради есть другие листы. спасибо за помощь
Вот обновление со всеми ранее упомянутыми комментариями и вашим недавним запросом.
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If TodayIsTheDay Then
ExportColumnsToCSV
End If
End Sub
Private Property Get TodayIsTheDay() As Boolean
' = 5 would be Friday
' = 6 would be Saturday
' = 1 would be Monday so on and so forth
If Weekday(Date, vbMonday) = 5 Then TodayIsTheDay = True
End Property
Private Sub ExportColumnsToCSV()
Dim wsTheWorksheetYouWant As Worksheet
' This is where you are going to change the worksheet name to the name you need
Set wsTheWorksheetYouWant = Application.Worksheets("yourWorksheetName")
Dim lBottomRow As Long
On Error Resume Next
lBottomRow = wsTheWorksheetYouWant.Range("$A:$A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
If lBottomRow <= 1 Then
' This assumes there is no data but still has coulmn headers.
MsgBox "there is only 1 row of data here"
Else
Dim rngTheRangeYouWant as range
Set rngTheRangeYouWant = wsTheWorksheetYouWant.Range("$A$1:$AJ$" & lBottomRow)
With rngTheRangeYouWant
Dim oNewWorkbook As Workbook
Set oNewWorkbook = Application.Workbooks.Add
rngTheRangeYouWant.Copy
With oNewWorkbook
.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
' If you want to make the name dynamic to the date then do it like this
Dim DatedFileName As String ' I Broke it up this way so you can make the filename dynamic as well
DatedFileName = Format(Date, "yyyymmdd") & "_" & "SomeGenericName" & ".csv"
'Change this to your path with extension like
.SaveAs Filename: = "C:\Users\yourpath\" & DatedFileName, FileFormat:=xlCSVUTF8, Local:=False
.Close
Application.DisplayAlerts = True
End With
End With
End If
Set rngTheRangeYouWant = Nothing
Set oNewWorkbook = Nothing
End Sub
Спасибо вам за быстрый ответ. Я потрачу некоторое время на тестирование и вернусь, если у меня возникнут вопросы.
Привет всем, @BWing, одна проблема, которую я заметил в коде, заключается в том, что он не работает с разделами «Private Sub Workbook_BeforeClose» и «Private Property Get TodayIsTheDay». Я изменил дату на понедельник = 1, и сегодня, в понедельник, CSV-файл не экспортировался. Если я удалю два раздела, названные выше, и запущу его вручную, он экспортирует CSV в мое местоположение SharePoint. Спасибо
Вы пытались отладить код, используя точку останова в строке с
dwb.SaveAs ..., и убедиться, что путь правильный?