Loop row selection copy with blank spaces

[Dave]

The code I have loops through a column of dates that have blank spaces
between different dates. For each date the rows between the blanks are
copied and saved as a seperate .csv file. This works fine if there a
two or more of the same date between the blanks. If there is only one
row for one date between the blanks it will copy that row, yet, not
continue to the next date, and the macro stops?

I have a modest clue of what I'm doing?
Any Help would be appreciated.

TIA

''///cell A1 is blank and selected to start

Do While IsEmpty(ActiveCell.Offset(1, 0)) = False

Dim i As Integer
i = ActiveCell.Row + 1
Do Until IsEmpty(Cells(i, 1).Value)
i = i + 1
Loop
Range(Cells(ActiveCell.Row + 1, 1), Cells(i - 1, 25)).Select


Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False


Range("A1").Select
x = Cells(1, 1).Value
ActiveWorkbook.SaveAs Filename:= _
"C:\" & x & ".csv", FileFormat _
:=xlCSV, CreateBackup:=False

ActiveWindow.Close

ActiveCell.End(xlDown).Offset(1, 0).Select

Loop



End Sub

 

[Jim Cone]

Dave,

Not much testing on this, added "rng".
See if it works for you...
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


'---------------------
Option Explicit
Sub TestingWhat()
''///cell A1 is blank and selected to start
Dim i As Long
Dim x
Dim rng As Excel.Range

Do While IsEmpty(ActiveCell.Offset(1, 0)) = False

i = ActiveCell.Row + 1
Do Until IsEmpty(Cells(i, 1).Value)
i = i + 1
Loop

Set rng = Range(Cells(ActiveCell.Row + 1, 1), Cells(i - 1, 25))

rng.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

Range("A1").Select
x = Cells(1, 1).Value
ActiveWorkbook.SaveAs Filename:="C:\" & x & ".csv", FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWindow.Close
rng(rng.Rows.Count + 1, 1).Select
Loop

Set rng = Nothing
End Sub
'-------------------------


The code I have loops through a column of dates that have blank spaces
between different dates. For each date the rows between the blanks are
copied and saved as a seperate .csv file. This works fine if there a
two or more of the same date between the blanks. If there is only one
row for one date between the blanks it will copy that row, yet, not
continue to the next date, and the macro stops?
I have a modest clue of what I'm doing?
Any Help would be appreciated.
TIA
....

 

[Dave]

Fantastic....I don't know why it works but it does.

Thank You very much



Sub InsertRowBetweenDates()


Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long


Set wks = Worksheets("sheet1")
With wks
FirstRow = 2 'headers in 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value
Then
'do nothing
Else
.Rows(iRow).Resize(1).Insert

End If
Next iRow
End With
End Sub


Sub TestingWhat()
''///cell A1 is blank and selected to start

Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False




Dim i As Long
Dim x
Dim rng As Excel.Range


Do While IsEmpty(ActiveCell.Offset(1, 0)) = False


i = ActiveCell.Row + 1
Do Until IsEmpty(Cells(i, 1).Value)
i = i + 1
Loop


Set rng = Range(Cells(ActiveCell.Row + 1, 1), Cells(i - 1, 25))


rng.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False


Range("A1").Select
x = Cells(1, 1).Value
ActiveWorkbook.SaveAs Filename:="C:\Documents and
Settings\DD\Desktop\DIVIDEND\Dividend\" & x & ".csv", FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWindow.Close
rng(rng.Rows.Count + 1, 1).Select
Loop


Set rng = Nothing



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

 

[Dave]

Fantastic....I don't know why it works but it does.

Thank You very much



Sub InsertRowBetweenDates()


Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long


Set wks = Worksheets("sheet1")
With wks
FirstRow = 2 'headers in 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value
Then
'do nothing
Else
.Rows(iRow).Resize(1).Insert

End If
Next iRow
End With
End Sub


Sub TestingWhat()
''///cell A1 is blank and selected to start

Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False




Dim i As Long
Dim x
Dim rng As Excel.Range


Do While IsEmpty(ActiveCell.Offset(1, 0)) = False


i = ActiveCell.Row + 1
Do Until IsEmpty(Cells(i, 1).Value)
i = i + 1
Loop


Set rng = Range(Cells(ActiveCell.Row + 1, 1), Cells(i - 1, 25))


rng.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False


Range("A1").Select
x = Cells(1, 1).Value
ActiveWorkbook.SaveAs Filename:="C:\" & x & ".csv", FileFormat _
:=xlCSV, CreateBackup:=False
ActiveWindow.Close
rng(rng.Rows.Count + 1, 1).Select
Loop


Set rng = Nothing



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub