The following code loops within a sheet.
I want to loop through all sheets in my workbook except for one sheet labeled "Summary".
For i = 2 To LR
If Abs(Range("J" & i)) > 0 Then
Range("A" & i & ":J" & i).Copy
Sheets("Sheet1").Range("A" & k).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
k = k + 1
Else
End If
Next i
Please try something like this
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Summary" Then
'Your code here
End If
Next
This is a simple For ... Next so why am I getting the error, is it related to the function somehow?
The macro I supposed to find a specific worksheet within a large workbook, get some data and copy it to a separate workbook named after the worksheet. Most of this came from mw recording a macro with changes were necessary.
Dim wbThisWB As Workbook
Dim LastRow As Long
Dim WSName As String
Dim lRow As Long
Workbooks.Open Filename:= _
"\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\16-17 EY Trainees test.xls"
LastRow = wbThisWB.Worksheets("Sheet1").Cells(Row.Count, 1).End(xlUp).Row
For I = 1 To LastRow
WSName = wbThisWB.Worksheets("Sheets1").Cells(I, 1)
If sheetExists(WSName, wbThisWB) Then
MsgBox "Sheet found:" & WSName
lRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("C2", "M" & lRow).Copy
Workbooks.Open Filename:="\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\" & WSName & " 17-18 AGR.xlsx"
Sheets("EY 17-18 Starters").Select
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Next I
End Sub
Function sheetExists(sheetToFinad As String, wbThisWB As Workbook) As Boolean
sheetExists = False
For Each Sheet In wbThisWB.Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
I have 4 sheets of data with thousands of rows in each sheet. There is one column within each sheet that I would like to consolidate into a 5th sheet. In this column, I'd like to make sure that every name from the previous four sheets is included in one comprehensive list with no repeats.
See a simple example below, but imagine 20,000 rows on each sheet with complex names. Can anyone think of a method of doing this, that does not require tweaking everytime the inputs change? I've been trying to use PivotChart Wizard with no luck.
Sheet 1 Sheet 2 Sheet 3 Sheet 4 Ideal Sheet 5
Dog Cat Fish Giraffe Dog
Hamster Dog Lhama Cat Cat
Giraffe Elephant Dog Fish Fish
Giraffe
Elephant
Hamster
Lhama
Here is the code I came up with to solve the problem in case anyone is interested. "Zone & Fam" just specifies the column I'm interested in.
Sub GetUniqueZoneFam()
Application.ScreenUpdating = False
Dim Lastrow As Long
Worksheets("Calculation Indv").Range("A:A").ClearContents
Worksheets("fcst fg").Activate
Range("Fcst_Fg[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("fcst ps").Activate
Range("Fcst_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales fg").Activate
Range("Sales_FG[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales ps").Activate
Range("Sales_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
Worksheets("Calculation Indv").Range("A1").Font.Bold = True
Application.ScreenUpdating = True
MsgBox ("Done!")
End Sub
In vba this would look something like the following (Totally not tested, written outside of VBE, probably riddled with mistakes, definitely will need tweaking to fit your sheet names and columns where your data lives):
Dim wsName as String
Dim lastRow as Long
Dim writeRow as Long
'set the row on which we are going to start writing data to "Sheet 5"
writeRow = 1
'Loop though your sheets to copy from
For Each wsName In Array("Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4")
'determine the last used row in the worksheet we are copying from
lastRow = Sheets(wsName).Range("A1").End(xlDown).Row
'grab the data
Sheets(wsName).Range("A1:A" & lastRow).Copy Destination:=Sheets("Sheet 5").Range("A" & writeRow)
'increment the writeRow
writeRow = writeRow + lastRow
Next wsName
'Now that all the data is copied, dedup it
Sheets("Sheet 5").Range("A1:A" & writeRow).RemoveDuplicates Columns:=Array(1), Header:=xlNo
Sub GetUniqueZoneFam()
Application.ScreenUpdating = False
Dim Lastrow As Long
Worksheets("Calculation Indv").Range("A:A").ClearContents
Worksheets("fcst fg").Activate
Range("Fcst_Fg[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("fcst ps").Activate
Range("Fcst_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales fg").Activate
Range("Sales_FG[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("sales ps").Activate
Range("Sales_PS[Zone & Fam]").Copy
Worksheets("Calculation Indv").Activate
Range("A" & Lastrow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Application.CutCopyMode = False
Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Worksheets("Calculation Indv").Range("A1").Value = "Zone & Fam"
Worksheets("Calculation Indv").Range("A1").Font.Bold = True
Application.ScreenUpdating = True
MsgBox ("Done!")
End Sub
I am trying to create a macro that takes a worksheet from a workbook, and then saves that worksheet as a single workbook but with all cells as values rather than formulas.
The bit I am struggling with is the paste values section.
This is what I have currently:
ThisWorkbook.Sheets("Tickets (1-48)").Copy
With ActiveWorkbook
For ColNr = 8 To 120
If Cells(RowNr, ColNr - 1) = "0" Then
TempValue = Cells(RowNr, ColNr - 1)
If TempValue = "0" Then
For i = 0 To 9
Cells(RowNr, ColNr - 1).Select
Cells(RowNr, ColNr - 1).EntireColumn.Delete
Next i
ColNr = ColNr - 1
Else
End If
Else
End If
Next ColNr
.SaveAs strpath & "\" & "Retail " & strFilename & "(1-48)" & ".xls"
.Close 0
End With
Ignore the section in the middle.
Thanks.
I'm not sure what your code is doing but you can adapt it to this. Here is the general code that a recorded macro will show you.
'Selects everything on the current sheet and copies it
Cells.Select
Selection.Copy
'Add a new workbook.
'Adding a new workbook makes it the active workbook so you can paste to it.
Workbooks.Add
'Paste the date using Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C8").Select
I am a bit new to the macro's in excel and I am trying to find a way to adjust one of the macros I currently have in an excel file. I have a calculation that takes the columns D and E then subtracts D from E and adds it to the value of column B. here is the current code and also the sheet being used.
Sub InvAdj()
'
' InvAdj Macro
'
' Keyboard Shortcut: Ctrl+Shift+I
'
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Select
ActiveCell.FormulaR1C1 = "Quality"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[2]+RC[3]"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C33")
Range("C2:C33").Select
Columns("C:C").Select
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("D2:E33").Select
Selection.ClearContents
Range("F1").Select
End Sub
Not sure if this is what you are trying?
Sub InvAdj()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("B1").Value = "Quality"
For i = 2 To 33
'~~> Check if all cells have data
If Len(Trim(.Range("B" & i).Value)) <> 0 And _
en(Trim(.Range("D" & i).Value)) <> 0 And _
en(Trim(.Range("E" & i).Value)) <> 0 Then
'B = B + (E - D)
.Range("B" & i).Value = .Range("B" & i).Value + _
(.Range("E" & i).Value - .Range("D" & i).Value)
End If
Next i
End With
End Sub