VBA to run macro then loop through other sheets - excel

I'm trying (and failing) to get some code to run on each worksheet except one specific sheet. I want the code to just cut the data in cells n2:s2 and paste it in t1:y1, then repeat for any other rows that have data in columns n3:s3, n4:s4, n5:s5.
Once there is no data (row 6 i believe), it should move onto the next sheet (except "Report" sheet).
The problem i'm facing when i debug is it moves the data as expected, then starts again on the same sheet, so overwrites data with empty cells.
Sub MovethroughWB()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'This statement starts the loop
If ws.Name <> "Report" Then 'Perform the Excel action you wish (turn cell yellow below)
Range("N2:S2").Select
Selection.Cut Destination:=Range("T1:Y1")
Range("T1:Y1").Select
Range("N3:S3").Select
Selection.Cut Destination:=Range("Z1:AE1")
End If
Next ws
End Sub
I'm sure its something basic, but can't find what!

Try:
Sub MovethroughWB()
Dim ws As Worksheet
Dim i As Long, Lastrow As Long, Lastcolumn As Long
For Each ws In ThisWorkbook.Worksheets 'This statement starts the loop
If ws.Name <> "Report" Then 'Perform the Excel action you wish (turn cell yellow below)
With ws
Lastrow = .Cells(.Rows.Count, "N").End(xlUp).Row
For i = 2 To Lastrow
If .Range("N" & i).Value <> "" And .Range("O" & i).Value <> "" And .Range("P" & i).Value <> "" _
And .Range("Q" & i).Value <> "" And .Range("R" & i).Value <> "" And .Range("S" & i).Value <> "" Then
If .Range("T1").Value = "" Then
.Range("N" & i & ":S" & i).Cut .Range("T1:Y1")
Else
Lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
.Range("N" & i & ":S" & i).Cut .Range(.Cells(1, Lastcolumn), .Cells(1, Lastcolumn + 5))
End If
End If
Next i
.Rows("2:" & Lastrow).EntireRow.Delete
End With
End If
Next ws
End Sub

Related

VBA to copy formula across variable rows and columns

I'm entering a value in the last blank cell (as I can't do the last row in a column) due to other data being there. I was to add the sum of all the above cells to each column.
The number of columns is variable as is the number of names
I've been able to add the relevant formula but I can't get it to copy across in the same way my other code did.
This is the line with the error, to copy to the last used column, everything else works except this bit.
Range("O" & nextfree).AutoFill Range("O" & nextfree, Cells("O" & nextfree, lastcolumn))
I get a run type error 13, Type mis-match.
The full code is here
Sub addrow()
'Checks the number of users then adds them to the active sheet section
Dim rowsToAdd As Integer
Dim lastcolumn As Long
Dim lastRow As Long
Dim ws As Worksheet, ws1 As Worksheet
Set ws = ThisWorkbook.Worksheets("Refs")
Set w1 = ThisWorkbook.Worksheets("Active events")
With ws
lastRow = Sheets("Refs").Cells(.Rows.Count, "A").End(xlUp).Row
lastcolumn = Sheets("Active events").Cells.Find("*", searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column
MsgBox lastRow - 1
MsgBox lastcolumn
End With
With ws1
Rows("5:5").Resize(lastRow - 1).Insert Shift:=xlDown ' minus 2 to account for header row and also existing text in row 4
End With
Worksheets("Refs").Range("A2:A" & lastRow).Copy Worksheets("Active events").Range("M4")
Range("O4:O" & lastRow + 2).Formula = "=SUMIF($C$14:$C$5032,$M4,O$14:O$5032)"
Range("O4:O" & lastRow + 2).AutoFill Range("O4", Cells(lastRow + 2, lastcolumn))
'Find the next blank cell in the names range and adds totals and the sum value to all columns
nextfree = Range("M4:M" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("M" & nextfree).Value = "Total"
Range("O" & nextfree).Value = "=SUM(O4:O" & nextfree - 1 & ")"
'Problem code here
Range("O" & nextfree).AutoFill Range("O" & nextfree, Cells("O" & nextfree, lastcolumn))
End Sub

Creating an automatic generated worksheet menu

I am struggling with fine tuning my VBA for an automatic generated worksheet menu. So far I have the following;
Dim objSheet As Worksheet
Worksheets("General Information").Activate
Range("W14").Select
For Each objSheet In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> objSheet.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & objSheet.Name & "'" & "!A1", TextToDisplay:=objSheet.Name
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireColumn.AutoFit
End If
Next objSheet
This works perfectly. However, I would like to have a fixed starting point as the first few sheets are always the same.
In other words I need this to work as of the 12th worksheet onwards.
Can you please help me out with this addition, thanks
Try like this:
Const intSheetStart As Integer = 12
Dim intCount As Integer
Dim objSheet As Worksheet
Worksheets("General Information").Activate
Range("W14").Select
intCount = 0
For Each objSheet In ActiveWorkbook.Worksheets
intCount = intCount + 1
If intSheetStart <= intCount Then
If ActiveSheet.Name <> objSheet.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & objSheet.Name & "'" & "!A1", TextToDisplay:=objSheet.Name
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireColumn.AutoFit
End If
End If
Next objSheet
This change sets the starting point in a constant, then counts the sheets and only runs the rest of the code if the current sheet is the starting point or after.
A different way of controlling it, is using another kind of loop, and set a starting point in the code.
For i = 12 To ActiveWorkbook.Worksheets.Count
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Worksheets(i).Name & "'" & "!A1", TextToDisplay:=Worksheets(i).Name
ActiveCell.Offset(1).Select
ActiveCell.EntireColumn.AutoFit
Next i
This starts the count at the 12th sheet as noted by i= 12 and then goes to the last sheet Worksheets.Count.
Also it's generally good practice to not select things, so here is a version without selecting a cell:
Sub links()
Dim ws As Worksheet
Set ws = Worksheets("General Information")
For i = 12 To ActiveWorkbook.Worksheets.Count
ws.Hyperlinks.Add Anchor:=ws.Cells(i + 2, 23), Address:="", SubAddress:="'" & Worksheets(i).Name & "'" & "!A1", TextToDisplay:=Worksheets(i).Name
Next i
Cells(1, 23).EntireColumn.AutoFit
End Sub
And for a more dynamic approach, as inspired by sbgib:
Sub menu()
Dim ws As Worksheet, printRow As Long, startCol As Long
Const startSheet As Long = 12 '- Which sheet number to start from
printCol = 23 '- Column "W" is column number 23
printRow = 14 '- First row to add hyperlinks to
Set ws = Worksheets("General Information")
printRow = printRow - startSheet
For i = startSheet To ActiveWorkbook.Worksheets.Count
ws.Hyperlinks.Add Anchor:=ws.Cells(printRow + i, printCol), Address:="", SubAddress:="'" & Worksheets(i).Name & "'" & "!A1", TextToDisplay:=Worksheets(i).Name
Next i
Cells(1, printCol).EntireColumn.AutoFit
End Sub

Copying the Cells Below A Text

I am trying to copy 3 entire rows below a cell which includes a text.
I've already wrote this but there are some issues that I can't solve due to being a beginner of VBA.
Option Explicit
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlup).Row
For iRow = lRow to 1 Step -1
If .Cells(iRow, "A").Value = Range("D5") Then
.Rows(iRow).Resize(3).Insert
End if
Next iRow
End With
End Sub
I want excel to read the entire A column and find the cell which has same text with cell D5 (Text is BillNumber). Then add 3 blank rows above that. Lastly copy the three cells below BillNumber and paste it to recently created 3 blank rows.
Here is screenshot to make it more understandable.
Here is one way, remove the MsgBox lines, they are for debugging.
Sub insertPaste()
Dim D5Val As String, wk As Workbook, fVal As Range
Set wk = ThisWorkbook
With wk.Sheets("Sheet1")
'Value from D5
D5Val = .Range("D5").Value
'Find D5 on column A
Set fVal = .Columns("A:A").Find(D5Val, , xlValues, , xlNext)
If fVal Is Nothing Then
'Not found
MsgBox "Not Found"
Else
'Found
MsgBox "Found at: " & fVal.Address
'Insert 3 Cells on top of the cell found with the data from the 3 cells below
.Range("A" & (fVal.Row + 1) & ":A" & (fVal.Row + 3)).Copy
.Range("A" & fVal.Row & ":A" & (fVal.Row + 2)).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
End With
End Sub
Copy Cells Below Text Above Text
The Code
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = lRow To 1 Step -1
If .Cells(iRow, "A").Value = .Range("D6") Then
.Rows(iRow).Resize(3).Insert
.Rows(iRow + 3 & ":" & iRow + 5).Copy .Rows(iRow)
End If
Next iRow
End With
End Sub

Copy and Paste using Range.Copy Method

I am trying to paste values from a bunch of tables into one long list. I have the tables spread across different sheets and the number of rows changes, but the columns do not. Then I am also trying to paste a string value that tells what sheet it came from, but having trouble with the active cell part of the code.
When I first tried it, it did not compile, hence why I came here, to figure out why it did not compile. Going back and forth with urdearboy, below, I was able to get the correct code working here.
I have the following:
sub copypaste()
Dim ws1 as worksheet
dim ws2 as worksheet
dim mas as worksheet
Set ws1 =ThisWorkbook.Sheets("Sheet1")
Set ws2=ThisWorkbook.Sheets("Sheet2")
Set mas=ThisWorkbook.Sheets("Master") 'where I create my list
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1, 0).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow - 1).Copy
mas.Range("A" & LRow).PasteSpecial Paste:=xlPasteValues
ws.Range("B2:B" & wsLRow - 1).Copy
mas.Range("B" & LRow).PasteSpecial Paste:=xlPasteValues
mas.Range(mas.Cells(LRow, 4), mas.Cells(wsLRow + LRow - 2, 4)) = ws.Name 'I need my sheet value in the fourth column, not the third, but simply change the col coordinate in the Cells equation above
End If
Next ws
'In order to figure out the sheet name, I used the following:
Dim rng As Range
Set rng = mas.Range("D2", Range("D2").End(xlDown))
For Each Cell In rng
If Cell.Value = "Sheet 1" Then
Cell.Value = "S1"
ElseIf Cell.Value = "Sheet 2" Then
Cell.Value = "S2"
End If
Next Cell
end sub
This will loop through all sheets, with the exception of Master, and import the values on Column A to Master accompanied by the origin of the data (sheet name).
Option Explicit for good measure.
Option Explicit
Sub copypaste()
Dim mas As Worksheet: Set mas = ThisWorkbook.Sheets("Master")
Dim ws As Worksheet, LRow As Long, wsLRow As Long
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
mas.Range(mas.Cells(LRow, 2), mas.Cells(wsLRow + LRow - 2, 2)) = ws.Name
End If
Next ws
Application.ScreenUpdating = True
End Sub
To paste values change
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
to this
ws.Range("A2:A" & wsLRow).Copy
mas.Range("A" & LRow).PasteSpecial xlPasteValues

macro to create multiple sub totals in one column

Can anyone help me with this macro to create multiple sub totals in one column? Any help would be great. I have a group of numbers in column Y. which begins at row 16.
The data is listed on every three lines until the end of that section then there is a gap of around thirty lines then it beings again. I want to create a macro to count how many numbers >45 in each section. Put the total 2 rows below the last data point of each section. In column X on the same row place Number>45
Sub Sample()
Dim result As Long, firstrow As Long, lastrow As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Lastrow in Col Y
lastrow = .Range("Y" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 16
'~~> Set your range
Set rng = .Range("Y" & firstrow & ":Y" & lastrow)
'~~> Put relevant values
.Range("x" & lastrow + 2).Value = "Total>45"
.Range("y" & lastrow + 2).Value = _
Application.WorksheetFunction.CountIf(rng, ">45")
End With
End Sub
try the below procedure
and loop backwards to ROW=1 like this:
Sub setTotals()
Dim iRow As Integer
Dim iLastRow As Integer
Dim sFormulaTargetAddress As String
iLastRow = ActiveSheet.Range("Y" & ActiveSheet.Rows.Count).End(xlUp).Row
iRow = iLastRow
Do Until iRow = 1
If Range("Y" & iRow).Value <> "" Then
'
' define the section
sFormulaTargetAddress = "Y" & Range("Y" & iRow).End(xlUp).Row & ":Y" & iRow & ""
'
' Put in the COUNTIF > 45 of the current section...
'
Range("Y" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
' '
'Range("X" & iRow + 2).Formula = "=COUNTIF(" & sFormulaTargetAddress & ","">45"")"
Range("X" & iRow + 2).value="Numbers > 45"
'
' find the next section
iRow = Range("Y" & iRow).End(xlUp).Row
If Range("Y" & iRow) <> "" Then iRow = Range("Y" & iRow).End(xlUp).Row
Else
iRow = Range("Y" & iRow).End(xlUp).Row
End If
Loop
End Sub
HTH
Philip

Resources