Sheet 0 : https://paste.pics/82a491cbc642d6fff555ef70612aec5b
Sheet 1 : https://paste.pics/cafe8628b76e56789cf03b06a923bde8
Sheet 2 : https://paste.pics/2320369d395a22c868b5e439b456ad3a
Sheet 3 : https://paste.pics/9fc84c7f43e1a2819d1537593c44c1f9
If match is found => "SUP" "AL" "AP" then Data should be cleared from all the sheets with one Button click
Button is in "Sheet0" => when clearing data the Headers should not get Cleared
if want to see my excel safe download 100%
https://drive.google.com/file/d/1w0n_srbhF02OhiWzKsB4IWWiwV5nO-Vl/view?usp=sharing
=========================================================================
This is my code where i tried But not working giving error at Ws.Range
Private Sub CommandCreate_new_Click()
Dim Ws As Worksheet
For Each Ws In Sheets(Array("Sheet1","Sheet2","Sheet3"))
Ws.Range ("I9:AM9")
.Cells.Replace what:=UCase("SUP"), Replacement:="", ReplaceFormat:=True
.Cells.Replace what:=UCase("SUP"), Replacement:="", ReplaceFormat:=False
.Cells.Replace what:=UCase("AL"), Replacement:="", ReplaceFormat:=True
.Cells.Replace what:=UCase("AL"), Replacement:="", ReplaceFormat:=False
Next Ws End Sub
========================================================================
Partially Working But not setting the Cell to => No fill Color [As match condition is found data should be deleted and even the cell color should be deleted and set to no fill color]
Private Sub CommandButton1_Click()
Dim Ws As Worksheet
For Each Ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
Ws.Range("A4", Ws.Range("A" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("B4", Ws.Range("B" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("C4", Ws.Range("C" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("D4", Ws.Range("D" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("E4", Ws.Range("E" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("F4", Ws.Range("F" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("G4", Ws.Range("G" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("H4", Ws.Range("H" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("I4", Ws.Range("I" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Ws.Range("J4", Ws.Range("J" & Rows.Count).End(xlUp).Offset(, 1)).ClearContents
Next Ws
End Sub
This is the below output i am getting after running the above partially code
[My output][1]: https://i.stack.imgur.com/6EbRP.png
Related
Hi I have bit of a code that has worked for a long time but it no longer works, we have recently been upgraded to 365, The code filers data on one worksheet then copies and paste into another worksheet but the paste no longer works. I am new to this so any help is much appreciated.
Thanks in advance.
This is the bit of code which is part of a longer module
Application.StatusBar = "GENERATE LIST OF LICENSES DUE TO EXPIRE"
Sheets("due to expire").Select
Columns("A:I").Select
Selection.ClearContents
Sheets("Import").Select
Range("B1").Select
Selection.AutoFilter
Dim lngStart As Long, lngEnd As Long
lngStart = Range("M1").Value 'assume this is the start date
lngEnd = Range("P1").Value 'assume this is the end date
Range("a1:I5000").AutoFilter field:=9, _
Criteria1:=">=" & lngStart, _
Operator:=xlAnd, _
Criteria2:="<=" & lngEnd
Range("a1:i5000").Select
Selection.Copy
Sheets("due to expire").Select
Range("a1").Select
ActiveSheet.PasteSpecial
Cells.EntireColumn.AutoFit
Number_of_Records = Sheets("Main").Range("L7").Value + 2
Selection_Range = Number_of_Records & ":1000000"
Rows(Selection_Range).Select
Selection.Delete Shift:=xlUp
Number_of_Records = Sheets("Main").Range("L7").Value + 1
Selection_Range = "J2:J" & Number_of_Records
Range("J2").Select
Selection.AutoFill Destination:=Range(Selection_Range)
Sheets("Import").Select
Range("B1").Select
Selection.AutoFilter
Range("C1").Select
Selection.AutoFilter
It could be the date format has changed so add a message box to check.
Sub DueToExpire()
Application.StatusBar = "GENERATE LIST OF LICENSES DUE TO EXPIRE"
Dim wsImport As Worksheet, wsDue As Worksheet
Dim lngStart As Long, lngEnd As Long
Set wsDue = Sheets("due to expire")
With wsDue
.Columns("A:I").ClearContents
End With
Set wsImport = Sheets("Import")
With wsImport
lngStart = .Range("M1").Value 'assume this is the start date
lngEnd = .Range("P1").Value 'assume this is the end date
MsgBox "Start date is " & Format(lngStart, "d mmm yyyy") & vbLf & _
"End date is " & Format(lngEnd, "d mmm yyyy")
With .Range("A1:I5000")
.AutoFilter Field:=9, Criteria1:=">=" & lngStart, _
Operator:=xlAnd, Criteria2:="<=" & lngEnd
.Copy
wsDue.Range("A1").PasteSpecial
.AutoFilter Field:=9
End With
End With
Number_of_Records = Sheets("Main").Range("L7").Value + 2
MsgBox "Number of records = " & Number_of_Records
With wsDue
.Rows(Number_of_Records & ":1000000").Delete Shift:=xlUp
.Range("J2").AutoFill Destination:=.Range("J2:J" & Number_of_Records - 1)
.Columns.AutoFit
End With
Application.StatusBar = ""
End Sub
I need to copy the last line of data, copy it with formulas to the row below it and then do a find and replace on the new last row - I got it to copy the line down but the find and replace isnt working - any tips? Thanks.
Sub CopyLastRowandReplace()
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim LastRow As Long
Dim ReplaceRow As Range
Set sourceSheet = ThisWorkbook.Worksheets("Book 1")
LastRow = sourceSheet.Range("B" & sourceSheet.Rows.Count).End(xlUp).Row
Set sourceRange = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
sourceRange.Offset(1).Formula = sourceRange.Formula
Set ReplaceRow = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
Range("B" & LastRow & ":N" & LastRow).Select
Selection.Replace What:="Aug", Replacement:="Sep", LookAt:=xlFormulas, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Core problems
LookAt:=xlFormulas. Sould be xlPart or xlWhole
You are not Replacing in the New last row (you haven't updated LastRow)
That said, there are other oportunities for improvement too
Sub Demo()
CopyLastRowandReplace ThisWorkbook.Worksheets("Book 1"), 2, 13, "Aug", "Sep"
End Sub
Sub CopyLastRowandReplace(sourceSheet As Worksheet, StartColumn As Long, NumColumns As Long, FindValue As Variant, ReplaceValue As Variant)
Dim sourceRange As Range
Set sourceRange = sourceSheet.Cells(sourceSheet.Rows.Count, StartColumn).End(xlUp).Resize(1, NumColumns)
With sourceRange
.Offset(1, 0).Formula = .Formula
.Offset(1, 0).Replace _
What:=FindValue, _
Replacement:=ReplaceValue, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=True, _
SearchFormat:=False, _
ReplaceFormat:=False
End With
End Sub
I am attempting to use variables in what should be a simple addition formula. First I search for the column header in row 3 call "Jan Expense Hours" MsgBox ColL comes back with the letter "I" and MsgBox ColL2 comes back with the letter "J", both of which are correct. lRow comes back with row 55 which is also correct. Although when I try to add these variables to Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'! & [ColL] & 4: & [ColL2] & 4)" I get an Application-defined or object-defined error on this line of code. Does anyone have an Idea what I am doing wrong? Btw, I'm searching for the column header because the columns do shift on various copies.
Full Procedure:
Sub JanTotHrsFind()
Dim lRow As Long
Dim lCol As Long
Dim strSearch As String
Dim aCell As Range
Dim ColL As String
Dim ColL2 As String
Dim ColNo As Long
Sheets("Resource Details").Activate
'find the column
strSearch = "*Jan Expense Hours*"
Set aCell = Sheets("Resource Details").Rows(3).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
'convert column number to letter
ColNo = aCell.Column
ColL = Split(Cells(, ColNo).Address, "$")(1)
ColL2 = Split(Cells(, (ColNo + 1)).Address, "$")(1) 'adds one more column to right
MsgBox ColL
MsgBox ColL2
lRow = Cells.Find(What:="SUBTOTAL*", _
After:=Range(ColL & "4"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row - 1 'minus 1 row to move above
MsgBox "Last Row: " & lRow
'formula for Jan Expense Hours + Jan Capital Hours
'Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'!I4:J4)"
'Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'![" & ColL & "]4:[" & ColL2 & "]4)"
Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'! & [ColL] & 4: & [ColL2] & 4)"
End Sub
You should not write your variables within brackets.
So:
Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'!" & [ColL] & "4:" & [ColL2] & "4)"
Can you please try your code as I corrected above and see how it goes.
In this user form
I have the following code (Ascending is by default TRUE, while Descending is False)
Private Sub OKButton_Click()
Dim rRange As Range
lastRow = Sheets("overview").Range("G1000").End(xlUp).Row
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:="Please select a cell in the column you want
_to sort", Title:="SPECIFY COLUMN", Type:=8)
Col = rRange.Columns(1).Column
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
If AscendingOption Then
Range("A14:CB" & lastRow).Sort key1:=Range(Col & "14:" & Col & lastRow), Order1:=xlAscending, Header:=xlNo, key2:=Range("C14:C" & lastRow), Order2:=xlAscending, Header:=xlNo
End If
If DescendingOption Then
Range("A14:CB" & lastRow).Sort key1:=Range(Col & "14:" & Col & lastRow), Order1:=xlDescending, key2:=Range("C14:C" & lastRow), Order2:=xlAscending
End If
End If
End Sub
When I click OK nothing happens: not an error message, nor any action.
Can anybody help me finding the error?
Both variables AscendingOption and DescendingOption are not initialized so are set as false. You need to change value of one of them into TRUE to sort. But in current code if both are TRUE, you will sort it twice - firstly ascending and secondly descending. You can reduce code by one variable into:
If AscendingOption Then
Range("A14:CB" & lastRow).Sort key1:=Range(Col & "14:" & Col & lastRow), Order1:=xlAscending, Header:=xlNo, key2:=Range("C14:C" & lastRow), Order2:=xlAscending, Header:=xlNo
Else
Range("A14:CB" & lastRow).Sort key1:=Range(Col & "14", Col & lastRow), Order1:=xlDescending, key2:=Range("C14:C" & lastRow), Order2:=xlAscending
End If
If AscendingOption is true, it sorts in in ascending order, otherwise descending.
This is the version of the code which works fine:
Private Sub OKButton_Click()
Dim rRange As Range
lastRow = Sheets("overview").Range("G1000").End(xlUp).Row
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:="Please select a cell in the column
_you want to sort", Title:="SPECIFY COLUMN", Type:=8)
Col = rRange.Columns(1).Column
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
If AscendingOption Then
Range("A14:CE" & lastRow).Sort key1:=Range(Cells(14, Col), Cells(lastRow, Col)),
_Order1:=xlAscending, Header:=xlNo, key2:=Range("C14:C" & lastRow),
_Order2:=xlAscending, Header:=xlNo
End If
If DescendingOption Then
Range("A14:CE" & lastRow).Sort key1:=Range(Cells(14, Col), Cells(lastRow, Col)),
_Order1:=xlDescending, Header:=xlNo, key2:=Range("C14:C" & lastRow),
_Order2:=xlAscending, Header:=xlNo
End If
Unload UserForm1
End If
End Sub
Following is the code to fetch the data from the last column of each sheet and display it in the sheet "MainSheet". Since the last column has merged cells this code also deletes the cells in between
This code displays the data as verical view in the MainSheet and I want to make it horizontal i.e data from the last column of each sheet should be fetched to the rows in the MainSheet and also the merged cells should be taken care of
Sub CopyLastColumns()
Dim cnt As Integer, sht As Worksheet, mainsht As Worksheet, col As Integer, rw As Integer
ActiveSheet.Name = "MainSheet"
Set mainsht = Worksheets("MainSheet")
cnt = 1
For Each sht In Worksheets
If sht.Name <> "MainSheet" Then
sht.Columns(sht.Range("A1").CurrentRegion.Columns.Count).Copy
mainsht.Columns(cnt).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
mainsht.Cells(150, cnt) = sht.Range("A2")
cnt = cnt + 1
End If
Next sht
With mainsht
For col = 1 To cnt
For rw = .Cells(65536, col).End(xlUp).row To 1 Step -1
If .Cells(rw, col) = "" Then
.Cells(rw, col).Delete Shift:=xlUp
End If
Next rw
Next col
End With
End Sub
Thanks in advance
This code copies the last column from every sheet and pastes them as rows in the MainSheet keeping the merged cells intact.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim wsOLrow As Long, wsILrow As Long, wsILcol As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wsO = Sheets("MainSheet")
wsOLrow = wsO.Cells.Find(What:="*", _
After:=wsO.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
For Each wsI In ThisWorkbook.Sheets
If wsI.Name <> wsO.Name Then
With wsI
wsILrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
wsILcol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.Range(Split(Cells(, wsILcol).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol).Address, "$")(1) & _
wsILrow).Copy .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Activate
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.UnMerge
.Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
wsILrow = .Range(Split(Cells(, wsILcol).Address, "$")(1) & Rows.Count).End(xlUp).Row
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Copy
wsO.Cells(wsOLrow, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
.Delete
End With
wsOLrow = wsOLrow + 1
End With
End If
Next
LetsContinue:
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub