Help me please! Basic Excel macro!

[IanCav]

I have this very simple macro to copy and past, values only, into certain cells within a worksheet.

I need the action to report on all but the first 9 sheets in the workbook (300 in total).

The macro below seems to be running but it is only actually performing the action on the first sheet in the sequence, sheet 10, all the rest remain unaltered.

Am I missing something very simple?


Sub DeleteActionData()
Dim ws As Worksheet
For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9"
Case Else
Range("C121:M130").Select
Selection.Copy
Range("C121").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Select
Next sh
End Sub

[Fluff]

Hi & welcome to the board.
How about
Sub DeleteActionData()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
Select Case Ws.Name
Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9"
Case Else
With Ws.Range("C121:M130")
.Value = .Value
End With
End Select
Next Ws
End Sub

[IanCav]

I feel a bit stupid right now!

The code I included actually works - problem is the other sheets in the file were 'highlighted' which is what was stopping the macro from working.

Thanks for your help though.



Hi & welcome to the board.
How about
Sub DeleteActionData()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
Select Case Ws.Name
Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9"
Case Else
With Ws.Range("C121:M130")
.Value = .Value
End With
End Select
Next Ws
End Sub

[Fluff]

You're welcome & thanks for the feedback.
However your original code will only convert the cells to values on whichever sheet is active when you run the macro.

[rajguptaji]

Hello All,

I am trying to copy the data from multiple sheets of a workbook into master workbook but getting script error 9. Please help.

Sub Rajeev()
Dim temp As New Workbook, wkb As Workbook
Dim sh, sh1, sh2, sh3, sh4, sh5, sh6 As Worksheet, w_dpr As Worksheet, w_cc As Worksheet, w_c1 As Worksheet, w_c2 As Worksheet, w_c3 As Worksheet, w_c4 As Worksheet, w_c5 As Worksheet, w_dpr1 As Worksheet, w_dpr2 As Worksheet, w_c9 As Worksheet
Dim MyFolder As String
Dim MyFile As String
Dim lRow As Long
Dim lrow1 As Long


Dim j As Integer, k As Integer, L As Integer


Set wkb = ThisWorkbook
Set w_dpr = wkb.Sheets("INSTALL(WIP)")
Set w_dpr1 = wkb.Sheets("Disconnect(WIP)")
Set w_dpr2 = wkb.Sheets("CCD")
Set w_cc = wkb.Sheets("Test & Accept Queue")
Set w_c1 = wkb.Sheets("Cancel Orders")
Set w_c2 = wkb.Sheets("Onshore Reassignment")
'Set w_c3 = wkb.Sheets("Billed_RTP-Orders")
'Set w_c4 = wkb.Sheets("CCD")
Set w_c5 = wkb.Sheets("ClickIT Tickets")




w_dpr.Range("A2:Z1000000").ClearContents
w_dpr1.Range("A2:Z1000000").ClearContents
w_dpr2.Range("A2:Z1000000").ClearContents


MyFolder = wkb.Sheets("Overall Snapshot").Range("AQ1").Value
MyFile = Dir(MyFolder & "\*.xls*")
Do While MyFile <> ""
Set temp = Workbooks.Open(Filename:=MyFolder & "" & MyFile)


On Error Resume Next
temp.Activate
Set sh = ActiveWorkbook.Sheets("INSTALL(WIP)")

If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Else
temp.Activate
sh.Activate
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If


lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row


sh.Range("A2:Z" & lRow).Copy


wkb.Activate
w_dpr.Activate

lrow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = lrow1 + 1


w_dpr.Range("A" & lrow1).Activate
w_dpr.Range("A" & lrow1).PasteSpecial


Application.CutCopyMode = False


End If


On Error Resume Next
temp.Activate
Set sh1 = ActiveWorkbook.Sheets("Test & Accept Queue")
If Err.Number <> 0 Then
'MsgBox "The sheet doesn't exist"
Err.Clear
On Error GoTo 0
Else
temp.Activate
sh1.Activate


If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If




lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
sh1.Range("A2:Z" & lRow).Copy


wkb.Activate
w_cc.Activate


lrow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = lrow1 + 1


w_cc.Range("A" & lrow1).Activate
w_cc.Range("A" & lrow1).PasteSpecial




Application.CutCopyMode = False

End If


On Error Resume Next
temp.Activate
Set sh2 = ActiveWorkbook.Sheets("Cancel Orders")
If Err.Number <> 0 Then
'MsgBox "The sheet doesn't exist"
Err.Clear
On Error GoTo 0
Else
temp.Activate
sh2.Activate


If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If




lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
sh2.Range("A2:Z" & lRow).Copy


wkb.Activate
w_c1.Activate


lrow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = lrow1 + 1


w_c1.Range("A" & lrow1).Activate
w_c1.Range("A" & lrow1).PasteSpecial




Application.CutCopyMode = False

End If



On Error Resume Next
Set sh3 = ActiveWorkbook.Sheets("Disconnect(WIP)")

If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Else
temp.Activate
sh3.Activate
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If


lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row


sh3.Range("A2:Z" & lRow).Copy


wkb.Activate
w_dpr1.Activate

lrow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = lrow1 + 1


w_dpr1.Range("A" & lrow1).Activate
w_dpr1.Range("A" & lrow1).PasteSpecial


Application.CutCopyMode = False


End If


On Error Resume Next
temp.Activate
Set sh4 = ActiveWorkbook.Sheets("CCD")

If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Else
temp.Activate
sh4.Activate
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If


lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row


sh4.Range("A2:Z" & lRow).Copy


wkb.Activate
w_dpr2.Activate

lrow1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = lrow1 + 1


w_dpr2.Range("A" & lrow1).Activate
w_dpr2.Range("A" & lrow1).PasteSpecial


Application.CutCopyMode = False


End If


temp.Close savechanges:=False
MyFile = Dir
Loop


wkb.Activate


w_dpr.Activate
w_dpr.Range("A1:A1000").Select
On Error Resume Next
w_dpr.Columns("A1:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("2:1000").RowHeight = 15
On Error GoTo 0


w_cc.Activate
w_cc.Range("A1:A1000").Select
On Error Resume Next
w_cc.Columns("A1:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Rows("2:1000").RowHeight = 15


w_c1.Activate
w_c1.Range("A1:A1000").Select
On Error Resume Next
w_c1.Columns("A1:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("2:1000").RowHeight = 15
On Error GoTo 0




End Sub

[Zack Barresse]

@rajguptaji, please start your own post.

[rajguptaji]

How to do that

[Zack Barresse]

26289