☰

¿Cómo puedo dividir una hoja de cálculo de Excel en varios archivos según la columna de fecha?

tag-icon • tag-icon microsoft-excel vba macros
¿Cómo puedo dividir una hoja de cálculo de Excel en varios archivos según la columna de fecha?

Necesito dividir una hoja de cálculo con 10.000 filas en varios archivos de Excel según las fechas de la columna D. El archivo tiene 9 columnas (A:I). Las fechas de la columna D actualmente tienen el formato DD/MM/AAAA. Solo quiero dividir el archivo en MMM/AAAA para que haya menos archivos. Aquí está mi código hasta ahora, divide la hoja de trabajo en varios archivos, pero cuando abro los archivos solo se ha copiado el encabezado, no los datos del mes y año relevantes.

¿Cómo puedo copiar y pegar todos los datos relevantes para MMM/AAAA en la columna D y cómo puedo guardar todos los archivos divididos en una carpeta específica como esta? C:\General\Londres\Clientes

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

Respuesta1

Lo principal fue reemplazar

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

con

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

Pero hice más cambios para poder copiar y pegar un poco más rápido. Como nota al margen, pegar no es una opción rápida; podría hacer algo como TargetCell.Value = SourceCell.Value(en este caso solo se transfieren los valores).

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

Respuesta2

Sub SplitData() ' ' Macro de datos divididos

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 como cadena FPath = Application.ActiveWorkbook.Path

Dim aCol como cadena aCol = "A"

En caso de error Ir a err1

Con Aplicación .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False Finalizar Con

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

Establecer objDictionary = CreateObject("Scripting.Dictionary")

Para nRow = 2 a nLastRow

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

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

Próximo

varColumnValues ​​= objDictionary.Keys

Para i = LBound(varColumnValues) a 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)

Próximo

err1: Con aplicación .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True Finalizar con

Subtítulo final

Función CheckDir (ruta como cadena)

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

Función final

información relacionada