rrosa1
07-04-2010, 07:16 AM
hi
i need to modified the following code to automation of macro as
count the cell which have value in column C and put the value in C1
and
sum the cell value in column H and put the value in H1
also in code it delete the row >=48 but not <= 0 is there anyway i can change the code to do delete the row <=0 and >=48
any help will be appreciated.
thanks for looking my problem.
ps here is my sample data wb
Option Explicit
Sub AppendData()
Dim ws As Worksheet
Dim i As Long
Dim ws1 As Worksheet
'Delete the sheet "Names" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Names").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "Names" Then
.Range("B1:T1").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(2)
.Range("A6:T59").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
Next ws
Set ws1 = ThisWorkbook.Worksheets("Names")
With ws1
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 8 Step -1
If .Cells(i, 8).Value >= 48 Then
.Rows(i).Delete
End If
Next i
End With
'Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
i need to modified the following code to automation of macro as
count the cell which have value in column C and put the value in C1
and
sum the cell value in column H and put the value in H1
also in code it delete the row >=48 but not <= 0 is there anyway i can change the code to do delete the row <=0 and >=48
any help will be appreciated.
thanks for looking my problem.
ps here is my sample data wb
Option Explicit
Sub AppendData()
Dim ws As Worksheet
Dim i As Long
Dim ws1 As Worksheet
'Delete the sheet "Names" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Names").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Names"
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "Names" Then
.Range("B1:T1").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(2)
.Range("A6:T59").Copy Destination:=Sheets("Names").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
Next ws
Set ws1 = ThisWorkbook.Worksheets("Names")
With ws1
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 8 Step -1
If .Cells(i, 8).Value >= 48 Then
.Rows(i).Delete
End If
Next i
End With
'Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub