suddivisione foglio excel

Question

Salve. ho un foglio excel di circa 60.000 righe; nella prima colonna c'è un codice che si ripete per n righe (diciamo circa 600 codici).

Avrei necessità di creare un foglio per ogni codice (nell'esempio 600 files circa), salvandoli con nome = al codice che li distingue (faccio l'esempio se le primi n righe hanno nella colonna a il campo "1234" vorrei creare un file che si chiami 1234 che contenga solo le righe che nella colonna a hanno quel campo)

spero di essere stato sufficientemente chiaro.

grazie.

Answer 1

scusate se rompo ancora.. ma siete fin troppo utili e vi chiedo una ulteriore info..

c'è maniera perchè i file che risultino dalla lavorazione abbiano lo stesso formato del file originario? (tipo carattere / larghezza colonne / colonne nascoste)

 

grazieeeeeeeeeeeeeee

 

Ciao,

sebbene il mio precedente già copiasse i formati, l'utilizzo di colonne nascoste, richiede un approccio leggermente diverso.

Andrea.

---

Sub ExtractData()

Dim wbTarget As Workbook

Dim wsTmp As Worksheet

Dim rSource As Range

Dim sFolderName As String

Dim i As Long

Dim arr As Variant, v As Variant

On Error GoTo Uffa

'--- cartella dove salvare i files

sFolderName = ThisWorkbook.Path & Application.PathSeparator

Application.ScreenUpdating = False

With ThisWorkbook

Set wsTmp = .Worksheets.Add

'--- modifica il nome del foglio

With .Worksheets("Foglio1")

.Columns(1).AdvancedFilter xlFilterCopy, , wsTmp.[a1], True

arr = wsTmp.[a1].CurrentRegion.Value

Application.DisplayAlerts = False

wsTmp.Delete

Application.DisplayAlerts = True

Set wsTmp = Nothing

Set rSource = .Cells

For i = 2 To UBound(arr)

v = arr(i, 1)

Application.StatusBar = "Voce in elaborazione: " & i & "/" & UBound(arr) & "  " & v

Set wbTarget = Workbooks.Add(1)

rSource.Copy wbTarget.Worksheets(1).Cells(1, 1)

With wbTarget

With .Worksheets(1).UsedRange

.AutoFilter 1, "<>" & v

.Offset(1).Resize(Rows.Count - 1).EntireRow.Delete

.AutoFilter

End With

Application.DisplayAlerts = False

.SaveAs sFolderName & v & ".xls", 56

.Close: Set wbTarget = Nothing

Application.DisplayAlerts = True

End With

Next

End With

End With

exitSub:

Application.StatusBar = False

Exit Sub

Uffa:

Call MsgBox("Si è verificato il seguente errore:" & vbNewLine & _

"Error Number: " & Err.Number & vbNewLine & _

"Description : " & Err.Description & vbNewLine & _

"Voce in elaborazione: " & v, vbOKOnly + vbCritical, "Error Message")

Resume exitSub

End Sub

---

Answer 2

Ciao Guglielmo,

Sostituisci il mio codice con il seguente lieve adattamento dove le modifiche sono in grassetto:

'==========>>

Option Explicit

'---------->>

Public Sub aTester()

Dim WB As Workbook

Dim newWB As Workbook

Dim SH As Worksheet

Dim Rng As Range

Dim srcRng As Range

Dim rCell As Range

Dim CalcMode As Long

Dim iLastRow As Long

Dim iLastCol As Long

Dim i As Long, j As Long

On Error GoTo ErrHandler

Set WB = Workbooks("TestIt.xlsx")                        '<<=== CAMBIA

Set SH = WB.Sheets("Foglio1")                              '<<=== CAMBIA

With SH

iLastRow = LastRow(SH, .Columns("A:A"))

iLastCol = LastCol(SH, .UsedRange)

Set Rng = .Range("A1").Resize(iLastRow, iLastCol)

End With

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For Each rCell In Rng.Columns(1).Cells

i = 1

j = j + i

With rCell

.Select

If .Value = .Offset(1).Value Then

'do nothing

Else

Set srcRng = rCell.Offset(-j + 1).Resize(j, iLastCol)

Set newWB = Workbooks.Add

With newWB

srcRng.Copy Destination:=.Sheets(1).Range("A1")

.SaveAs Filename:=rCell.Value & ".xlsx", _

FileFormat:=xlWorkbookNormal

.Close SaveChanges:=True

End With

j = 0

End If

End With

Next rCell

XIT:

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

On Error GoTo 0

Exit Sub

ErrHandler:

Call MsgBox(Prompt:="Errore " _

& Err.Number _

& " (" & Err.Description _

& ") nella procedura aTester")

Resume XIT

End Sub

'--------------->

Function LastRow(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

After:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

'--------------->

Function LastCol(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastCol = Rng.Find(What:="*", _

After:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Column

On Error GoTo 0

End Function

'<<==========

===

Regards,

Norman

Answer 3

grazie!

vi chiedo solo una ulteriore cosa, che mi ero dimenticato prima.. in realtà la prima riga del foglio dovrei ripeterla in ogni foglio / file (diciamo che rappresenta l'intestazione di ogni colonna..).

In sostanza .. come devo modificare la macro per far si che la riga 1 sia la riga 1 del foglio origini e si mantenga uguale in tutti i file?

Grazie!

Answer 4

Salve. ho un foglio excel di circa 60.000 righe; nella prima colonna c'è un codice che si ripete per n righe (diciamo circa 600 codici).

Avrei necessità di creare un foglio per ogni codice (nell'esempio 600 files circa), salvandoli con nome = al codice che li distingue (faccio l'esempio se le primi n righe hanno nella colonna a il campo "1234" vorrei creare un file che si chiami 1234 che contenga solo le righe che nella colonna a hanno quel campo)

 

spero di essere stato sufficientemente chiaro.

 

grazie.

Ciao,

copia la macro allegata in un modulo generale del file che contiene i dati da suddividere, modifica nella riga evidenziata, il nome del foglio che contiene i dati.

Andrea.

---

Sub ExtractData()

Dim wbTarget As Workbook

Dim wsTmp As Worksheet

Dim sFolderName As String

Dim i As Long

Dim arr As Variant, v As Variant

On Error GoTo Uffa

'--- cartella dove salvare i files

sFolderName = ThisWorkbook.Path & Application.PathSeparator

Application.ScreenUpdating = False

'--- filtra valori univoci colonna A

With ThisWorkbook

Set wsTmp = .Worksheets.Add

'--- modifica il nome del foglio

With .Worksheets("Foglio1")

'--- se non contiene intestazione

.Cells(1, 1).EntireRow.Insert

.Cells(1, 1).Value = "@#[]{}"

.Columns(1).AdvancedFilter xlFilterCopy, , wsTmp.[a1], True

.Cells(1, 1).EntireRow.Delete

arr = wsTmp.[a1].CurrentRegion.Value

Application.DisplayAlerts = False

wsTmp.Delete

Application.DisplayAlerts = True

Set wsTmp = Nothing

With .UsedRange

For i = 2 To UBound(arr)

v = arr(i, 1)

Application.StatusBar = "Voce in elaborazione: " & v

Set wbTarget = Workbooks.Add()

.AutoFilter 1, v

.Copy wbTarget.Worksheets(1).[a1]

wbTarget.SaveAs sFolderName & v & ".xls", 56

wbTarget.Close: Set wbTarget = Nothing

Next

.AutoFilter

End With

End With

End With

exitSub:

Application.StatusBar = False

Exit Sub

Uffa:

Call MsgBox("Si è verificato il seguente errore:" & vbNewLine & _

"Error Number: " & Err.Number & vbNewLine & _

"Description : " & Err.Description & vbNewLine & _

"Voce in elaborazione: " & v, vbOKOnly + vbCritical, "Error Message")

Resume exitSub

End Sub

---

Answer 5

Salve. ho un foglio excel di circa 60.000 righe; nella prima colonna c'è un codice che si ripete per n righe (diciamo circa 600 codici).

Avrei necessità di creare un foglio per ogni codice (nell'esempio 600 files circa), salvandoli con nome = al codice che li distingue (faccio l'esempio se le primi n righe hanno nella colonna a il campo "1234" vorrei creare un file che si chiami 1234 che contenga solo le righe che nella colonna a hanno quel campo)

 

spero di essere stato sufficientemente chiaro.

 

grazie.

Ciao Guglielmo,

Prova qualcosa del genere:

Alt-F11 per aprire l'editor VBA

Alt-IM per aprire un nuovo modulo di codice

Incolla il seguente codice:

'==========>>

Option Explicit

'---------->>

Public Sub aTester()

Dim WB As Workbook

Dim newWB As Workbook

Dim SH As Worksheet

Dim Rng As Range

Dim srcRng As Range

Dim rCell As Range

Dim iLastRow As Long

Dim iLastCol As Long

Dim i As Long, j As Long

On Error GoTo ErrHandler

Set WB = Workbooks("TestIt.xls")                     '<<=== CAMBIA

Set SH = WB.Sheets("Foglio1")                         '<<=== CAMBIA

With SH

iLastRow = LastRow(SH, .Columns("A:A"))

iLastCol = LastCol(SH, .UsedRange)

Set Rng = .Range("A1").Resize(iLastRow, iLastCol)

End With

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For Each rCell In Rng.Columns(1).Cells

i = 1

j = j + i

With rCell

.Select

If .Value = .Offset(1).Value Then

'do nothing

Else

Set srcRng = rCell.Offset(-j + 1).Resize(j, iLastCol)

Set newWB = Workbooks.Add

With newWB

srcRng.Copy Destination:=.Sheets(1).Range("A1")

.SaveAs Filename:=rCell.Value & ".xls", _

FileFormat:=51

.Close SaveChanges:=True

End With

j = 0

End If

End With

Next rCell

XIT:

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

On Error GoTo 0

Exit Sub

ErrHandler:

Call MsgBox(Prompt:="Errore " _

& Err.Number _

& " (" & Err.Description _

& ") nella procedura AggiornaArchivio")

Resume XIT

End Sub

'--------------->

Function LastRow(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

After:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

'--------------->

Function LastCol(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastCol = Rng.Find(What:="*", _

After:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Column

On Error GoTo 0

End Function

'<<==========

Alt-Q per chiudere l'editor di VBA

Alt-F8 per aprire la finestrina Macro

Seleziona aTester | Esegui

---

---

===

Regards,

Norman