☰

Как разделить один лист Excel на несколько файлов на основе столбца даты?

tag-icon • tag-icon microsoft-excel vba macros
Как разделить один лист Excel на несколько файлов на основе столбца даты?

Мне нужно разделить рабочий лист с 10 000 строк на несколько файлов Excel на основе дат в столбце D. В файле 9 столбцов (A:I). Даты в столбце D в настоящее время отформатированы как ДД/ММ/ГГГГ. Я хочу разделить файл только на МММ/ГГГГ, чтобы было меньше файлов. Вот мой код на данный момент, он разделяет рабочий лист на несколько файлов, но когда я открываю файлы, копируется только заголовок, а не данные для соответствующего месяца и года.

Как скопировать и вставить все данные, которые относятся к MMM/YYYY в столбце D, и как сохранить все разделенные файлы в определенной папке, например, этой? C:\General\London\Clients

Sub SplitData()
'
' SplitData Macro

Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet

Dim aCol As String
aCol = "D"

On Error GoTo err1

 With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
 End With

Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

Set objDictionary = CreateObject("Scripting.Dictionary")

 For nRow = 1 To nLastRow

    strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy")

    If objDictionary.Exists(strColumnValue) = False Then
       objDictionary.Add strColumnValue, 1
    End If
Next

varColumnValues = objDictionary.Keys

For i = LBound(varColumnValues) To UBound(varColumnValues)
    varColumnValue = varColumnValues(i)


    Set objExcelWorkbook = Excel.Application.Workbooks.Add

    Set objSheet = objExcelWorkbook.Sheets(1)
    objSheet.Name = objWorksheet.Name

    objWorksheet.Rows(1).EntireRow.Copy
    objSheet.Activate
    objSheet.Range("A1").Select
    objSheet.Paste

     For nRow = 1 To nLastRow
        If CStr(objWorksheet.Range(aCol & nRow).Value) = CStr(varColumnValue) Then

           objWorksheet.Rows(nRow).EntireRow.Copy

           nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
           objSheet.Range("A" & nNextRow).Select
           objSheet.Paste
           objSheet.Columns("A:I").AutoFit
        End If
    Next
    objExcelWorkbook.SaveAs (CStr(varColumnValue))
Next

err1:
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
     End With

End Sub

решение1

Главное было заменить

If CStr(objWorksheet.Range(aCol & nRow).Value) = CStr(varColumnValue) Then

с

If Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy") = varColumnValue Then

Но я сделал больше изменений, чтобы копировать-вставлять немного быстрее. Кстати, вставка — это не быстрый вариант, можно сделать что-то вроде TargetCell.Value = SourceCell.Value(в этом случае переносятся только значения).

Sub SplitData()
  '
  ' SplitData Macro

  Dim objWorksheet As Excel.Worksheet
  Dim nLastRow As Integer, nRow As Integer, nNextRow As Integer
  Dim strColumnValue As String
  Dim objDictionary As Object
  Dim varColumnValues As Variant
  Dim varColumnValue As Variant
  Dim objExcelWorkbook As Excel.Workbook
  Dim objSheet As Excel.Worksheet
  Dim i As Long

  Dim aCol As String
  aCol = "D"

  On Error GoTo err1

  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
  End With

  Set objWorksheet = ActiveSheet
  nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

  Set objDictionary = CreateObject("Scripting.Dictionary")

  For nRow = 2 To nLastRow

    strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy")

    If objDictionary.Exists(strColumnValue) = False Then
      objDictionary.Add strColumnValue, 1
    End If
  Next

  varColumnValues = objDictionary.Keys

  For i = LBound(varColumnValues) To UBound(varColumnValues)
    varColumnValue = varColumnValues(i)

    Set objExcelWorkbook = Excel.Application.Workbooks.Add

    Set objSheet = objExcelWorkbook.Sheets(1)
    objSheet.Name = objWorksheet.Name

    objSheet.Rows(1).Value = objWorksheet.Rows(1).Value
    objWorksheet.Rows(1).Copy objSheet.Rows(1)

    nNextRow = 2
    For nRow = 1 To nLastRow
      If Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy") = varColumnValue Then
        objWorksheet.Rows(nRow).Copy objSheet.Rows(nNextRow)
        nNextRow = nNextRow + 1
      End If
    Next
    objSheet.Columns("A:I").AutoFit
    ' Closing the workbook with changes saved
    objExcelWorkbook.Close True, CStr(varColumnValue)

  Next

err1:
  With Application
   .ScreenUpdating = True
   .Calculation = xlCalculationAutomatic
   .EnableEvents = True
  End With

End Sub

решение2

Sub SplitData() ' ' Макрос SplitData

Dim objWorksheet As Excel.Worksheet Dim nLastRow As Integer, nRow As Integer, nNextRow As Integer Dim strColumnValue As String Dim objDictionary As Object Dim varColumnValues ​​As Variant Dim varColumnValue As Variant Dim objExcelWorkbook As Excel.Workbook Dim objSheet As Excel.Worksheet Dim i As Long Dim FPath As String FPath = Application.ActiveWorkbook.Path

Размер aCol как String aCol = "A"

При ошибке GoTo err1

С приложением .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False Конец с

Установить objWorksheet = ActiveSheet nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

Установить objDictionary = CreateObject("Scripting.Dictionary")

Для nRow = 2 до nLastRow

strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "mmm_yyyy")

If objDictionary.Exists(strColumnValue) = False Then
  objDictionary.Add strColumnValue, 1
End If

Следующий

varColumnValues ​​= objDictionary.Keys

Для i = LBound(varColumnValues) Для UBound(varColumnValues) varColumnValue = varColumnValues(i)

Set objExcelWorkbook = Excel.Application.Workbooks.Add

Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name

objSheet.Rows(1).Value = objWorksheet.Rows(1).Value
objWorksheet.Rows(1).Copy objSheet.Rows(1)

nNextRow = 2
For nRow = 1 To nLastRow
  If Format(objWorksheet.Range(aCol & nRow).Value, "mmm_yyyy") = varColumnValue Then
    objWorksheet.Rows(nRow).Copy objSheet.Rows(nNextRow)
    nNextRow = nNextRow + 1
  End If
Next
objSheet.Columns("A:K").AutoFit
CheckDir (FPath & "\" & varColumnValue)
objExcelWorkbook.SaveAs FPath & "\" & varColumnValue & "\" & "Report.xlsx"
' Closing the workbook with changes saved
objExcelWorkbook.Close True, CStr(varColumnValue)

Следующий

err1: С приложением .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True Завершить с

Конец субтитра

Функция CheckDir(путь как строка)

If Dir(Path, vbDirectory) = "" Then
    MkDir (Path)
End If

Конечная функция

Связанный контент