Sub CopyData() Dim reference As String Dim sheetSrc As Worksheet Dim sheetDst As Worksheet Dim oRange As Range Dim maxRow As Long Set sheetSrc = Sheets("Feuil1") Do While WorksheetFunction.CountA(sheetSrc.Range("A2:A65536")) > 0 maxRow = sheetSrc.Range("A:A").SpecialCells(xlCellTypeLastCell).Row reference = sheetSrc.Range("A2").Text Set oRange = sheetSrc.Range("A3") '# Loop through all col A values until a non-blank cell value that does not match A2's value is found Do If LenB(oRange.Text) > 0 And oRange.Text <> reference Then Exit Do End If Set oRange = oRange.Offset(1) Loop While oRange.Row < maxRow 'Copy data from columns A - G Set oRange = sheetSrc.Range("A2", sheetSrc.Cells(oRange.Row - 1, 7)) Set sheetDst = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sheetDst.Name = reference oRange.Copy sheetDst.Range("A3") oRange.EntireRow.Delete Loop End Sub
Dim dercel As Range, deb As Range, dest As Worksheet Do With Sheets("Feuil1") Set dercel = .Cells.SpecialCells(xlCellTypeLastCell) Set deb = .Range("A" & dercel.Row).End(xlUp) If deb.Row = 1 Then Exit Do Set dest = Worksheets.Add(After:=Worksheets(Worksheets.Count)) dest.Name = .Range(deb.Address) .Range(deb.Address, dercel.Address).Copy Destination:=dest.Range("A1") .Range(deb.Address, dercel.Address).EntireRow.Delete End With Loop
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionDo While WorksheetFunction.CountA(Range("A2:A65536")) <> 0et c'est là que j'avais le message d'erreur.
Range("A2:G" & CStr(LRow - 1)).Select Selection.Copy ThisWorkbook.Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = x Worksheets(x).Paste Destination:=Worksheets(x).Range("A3") Sheets("Feuil1").Select Selection.EntireRow.Delete
Sub CopyData() Dim index As String Dim sheetSrc As Worksheet Dim sheetDst As Worksheet Dim oRange As Range Set sheetSrc = Sheets("Feuil1") Do While WorksheetFunction.CountA(sheetSrc.Range("A2:A65536")) > 0 index = sheetSrc.Range("A2").Text Set oRange = sheetSrc.Range("A3") '# Loop through all col A values until a non-blank cell value that does not match A2's value is found Do If oRange.Text <> index Then Exit Do End If Set oRange = oRange.Offset(1) Loop 'Copy data from columns A - G Set oRange = sheetSrc.Range("A2", sheetSrc.Cells(oRange.Row - 1, 7)) Set sheetDst = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sheetDst.Name = index oRange.Copy sheetDst.Range("A3") oRange.EntireRow.Delete Loop End Sub
Set dest = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Set dest = Worksheets.Add(before:=Worksheets(1))
With Sheets("Feuil1") Dim plage As Range, dercel As Range, dest As Worksheet Set dercel = .Cells.SpecialCells(xlCellTypeLastCell) Set plage = .Range("A2:A" & dercel.Column) Set plage = plage.SpecialCells(xlCellTypeConstants) For i = plage.Areas.Count To 1 Step -1 Set dest = Worksheets.Add(before:=Worksheets(1)) dest.Name = plage.Areas(i) .Range(plage.Areas(i), dercel).Copy Destination:=dest.Range("A1") Set dercel = .Cells(plage.Areas(i).Row - 1, dercel.Column) Next .Cells.ClearContents End With