I was wondering how I can paste it starting from row 41. Thanks in advance.
A. Hoek
Sub COPY()
Dim nextrow As Long
Dim i As Integer
i = 41
nextrow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheet1
.Range("a2").COPY Sheet2.Range("A" & nextrow)
.Range("b2").COPY Sheet2.Range("B" & nextrow)
.Range("C2").COPY Sheet2.Range("C" & nextrow)
.Range("d2").COPY Sheet2.Range("D" & nextrow)
.Range("e2").COPY Sheet2.Range("E" & nextrow)
.Range("f2").COPY Sheet2.Range("F" & nextrow)
.Range("g2").COPY Sheet2.Range("G" & nextrow)
End With
End Sub
You mean like this?
Sub COPY()
Dim nextrow As Long
Dim i As Integer
i = 41
nextrow = WorksheetFunction.Max(i, Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1)
Sheet1.Range("a2:g2").COPY Sheet2.Cells(nextrow, "A")
End Sub
How about:
Sub COPY()
Dim nextrow As Long
Dim i As Integer
i = 41
nextrow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheet1
.Range("a" & i).COPY Sheet2.Range("A" & nextrow)
.Range("b" & i).COPY Sheet2.Range("B" & nextrow)
.Range("C" & i).COPY Sheet2.Range("C" & nextrow)
.Range("d" & i).COPY Sheet2.Range("D" & nextrow)
.Range("e" & i).COPY Sheet2.Range("E" & nextrow)
.Range("f" & i).COPY Sheet2.Range("F" & nextrow)
.Range("g" & i).COPY Sheet2.Range("G" & nextrow)
End With
End Sub
Related
I have been trying to create a function with copies the next cell and paste data into same cell but i really do not know how to create it.
Any help will be much appreciated.
Dim Lrow As Long
With Sheet1
Lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("C2:C" & Lrow).Copy Sheet7.Range("A2")
.Range("I2:I" & Lrow).Copy Sheet7.Range("C2")
.Range("B2:B" & Lrow).Copy Sheet7.Range("D2")
.Range("G2:G" & Lrow).Copy Sheet7.Range("E2")
.Range("S2:S" & Lrow).Copy Sheet7.Range("F2")
.Range("D2:D" & Lrow).Copy Sheet7.Range("H2")
.Range("E2:E" & Lrow).Copy Sheet7.Range("I2")
.Range("L2:L" & Lrow).Copy Sheet7.Range("J2")
.Range("N2:N" & Lrow).Copy Sheet7.Range("K2")
.Range("Q2:Q" & Lrow).Copy Sheet7.Range("L2")
.Range("R2:R" & Lrow).Copy Sheet7.Range("M2")
.Range("M2:M" & Lrow).Copy Sheet7.Range("N2")
End Wit
Give a try to below codes.
Sub MyCopy()
Dim Lrow As Long
With Sheet1
Lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Lrow <= 2 Then
Exit Sub
Else
.Range("C" & Lrow).Copy Sheet7.Range("A2")
.Range("I" & Lrow).Copy Sheet7.Range("C2")
.Range("B" & Lrow).Copy Sheet7.Range("D2")
.Range("G" & Lrow).Copy Sheet7.Range("E2")
.Range("S" & Lrow).Copy Sheet7.Range("F2")
.Range("D" & Lrow).Copy Sheet7.Range("H2")
.Range("E" & Lrow).Copy Sheet7.Range("I2")
.Range("L" & Lrow).Copy Sheet7.Range("J2")
.Range("N" & Lrow).Copy Sheet7.Range("K2")
.Range("Q" & Lrow).Copy Sheet7.Range("L2")
.Range("R" & Lrow).Copy Sheet7.Range("M2")
.Range("M" & Lrow).Copy Sheet7.Range("N2")
End If
End With
End Sub
I have coded a form for entering product information that works and would like to clean it up. Currently for every product division, I have copied and pasted the same code to take the values from the form and apply them to the correct division sheet. I would like to have the code occur once, and then reference it in the code for the 22 divisions. I have not been able to find a solution to this, likely because I do not know the proper terminology.
Here is a section of what I would like to fix:
Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Case "DIVISION 26 - ELECTRICAL"
Set ws = Sheets("Div-26")
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Case "DIVISION 27 - COMMUNICATIONS"
Set ws = Sheets("Div-27")
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Here is what I would like to do if possible:
[Refrence Code]=
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
[Refrence code]
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
[Refrence code]
Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")
[Refrence code]
Case "DIVISION 26 - ELECTRICAL"
Set ws = Sheets("Div-26")
[Refrence code]
Case "DIVISION 27 - COMMUNICATIONS"
Set ws = Sheets("Div-27")
[Refrence code]
Any help would be appreciated. If possible, please explain in a clear and detailed way since I am still very much a novice at VBA coding and a beginner at coding in general.
The part that changes is ws. Keep the Select Case and move the repetitive block afterwards.
Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-23")
...
Case Else
' handle other cases, perhaps `Exit Sub`
End Select
' Now you need only one instance of the repetitive block
' You've got the right `ws` from above.
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
... and so on
If you are dealing with a repetitive DIVISION - ## - .... pattern, then you could refactor your Select Case into a separate function that parses the sheet name instead of listing all the possibilities as you currently do.
Looking to not repeat code is great thing. In this case you can simply just do the following:
Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
End Select
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
But as you are learning about how to "trim down code", I wanted to cover also calling a sub with arguments, like so.
Sub SheetSelect()
Dim ws as worksheet
Case "DIVISION 21 - FIRE SUPPRESSION"
Set ws = Sheets("Div-21")
Call DoStuff(ws)
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")
Call DoStuff(ws)
End Select
End Sub
Sub DoStuff(ws As WorkSheet)
LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
ws.Range("d" & LastRow).Value = Me.TextBoxProduct_Generic_Name.Value
ws.Range("e" & LastRow).Value = Me.TextBoxProduct_Manufacturer.Value
ws.Range("s" & LastRow).Value = Me.TextBoxAuthor_Initials.Value
ws.Range("f" & LastRow).Value = Me.TextBoxModel_Name.Value
ws.Range("k" & LastRow).Value = Me.TextBoxProduct_Serial_Number.Value
ws.Range("g" & LastRow).Value = Me.TextBox_Website_Link.Value
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("j" & LastRow).Value = Me.TextBoxColor.Value
ws.Range("r" & LastRow).Value = Me.TextBoxLocal_Locations.Value
ws.Range("l" & LastRow).Value = Me.TextBoxFeatures.Value
ws.Range("h" & LastRow).Value = Me.TextBoxComments.Value
ws.Range("m" & LastRow).Value = Me.TextBoxSales_Rep_Name.Value
ws.Range("n" & LastRow).Value = Me.TextBoxSales_Rep_Phone.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value
End Sub
I don't know what it accepted practice/best policy, but I often put separate subs in separate modules so that I don't have modules that are super long. I also have a "main" module which only calls each sub that does something. This allows me to comment out subs for debugging and re-introduce them one by one.
Eg:
Sub Main_Sub()
Call First_Task
'Call Second_Task ' Comment out "Second Task" for debugging till "First_Task" works as expected, this also allows for future debugging.
End Sub
Writing macros to copy cells in a different workbook in a specific format.Getting error at different lines everytime I run the code
I tried with unhide cells, selection
For i = 1 To lastrow
If IsEmpty(ThisWorkbook.Sheets("Summary").Range("A" & i).Value) = False Then
If ThisWorkbook.Sheets("Summary").Range("A" & i).Font.Bold = True Then
'Range("A" & i).Copy Range("B" & i)
Set BoldTitle = ThisWorkbook.Sheets("Summary").Range("A" & i)
x = i
Else
ws.Range("A" & i).Value = "Winter I"
BoldTitle.Copy
ws.Range("B" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("A" & i).Copy
ws.Range("C" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("B" & i).Copy
ws.Range("D" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("C" & i).Copy
ws.Range("E" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("D" & i).Copy
ws.Range("F" & i).PasteSpecial xlPasteValues
End If
Else
End If
Next i
I have workbook namely "OPTIONS", having multiple sheets. Data is in sheets no. 4 to 31; in columns A, B, C and D in different multiple rows. All 4 to 31 sheets have different names. In all 4 to 31 sheets, in column C have two names called "CE" and "PE". I want find CE name and copy data from column D ( which is in front of CE ) and paste in sames respective sheets in column F. Same find CE name copy data from column B and paste in column G to their respective sheets. Again now find PE name copy data in from column D and copied data should paste in column H to their respective sheets. Again find PE name copy data from column B and paste in column I. Paste should start from row 2 i.e. below heading.
In conclusion, available data is from 4 to 31 sheets having different names, in column A B C and D. Find two names from column C from all sheets and paste data from D to F, from B to G, from D to H and from B to I; in their respective sheets.
Thanks in advance.
I have tried code for first three sheets and its working fine. But the code will go too long. Expecting short code. I am not understanding how should I post my example code here. Someone please help.
Sub watermasa()
Dim x As String, y As String
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
With Sheets("ADANIENT")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("ADANIPORTS")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("APOLLOTYRE")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("ARVIND")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ARVIND").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
End Sub
You can loop through the worksheets by walking through an array of their worksheet names or by the ordinal index number of their current position in the worksheet queue.
Sub watermasa_by_Name()
Dim x As String, y As String, lrc As Long, v As Long, vWSs As Variant
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
vWSs = Array("ADANIENT", "ADANIPORTS", "APOLLOTYRE", "ARVIND")
For v = LBound(vWSs) To UBound(vWSs)
With Sheets(vWSs(v))
lrc = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & lrc).AutoFilter 1, x
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("G" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & lrc).AutoFilter 1, y
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("H" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("I" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
Next v
End Sub
Sub watermasa_by_Index()
Dim x As String, y As String, lrc As Long, w As Long
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
For w = 4 To 31 ' maybe For w = 4 To sheets.count ?
With Sheets(w)
lrc = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & lrc).AutoFilter 1, x
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("G" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & lrc).AutoFilter 1, y
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("H" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("I" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
Next w
End Sub
I'm not sure why you used the With ... End With statement for the copy and not the paste operation but it does clean up your code a bit.
I have the following code block to take out various errors and assign an error code description to the data. It works fine as long as the filter returns a result. If it does not then it deletes the header row. How can I prevent that from happening? Thanks in advance.
Sheets("Tempsheet").Select
Range("A1:K1").AutoFilter
Range("A1:K1").AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
Sheets("Excluded").Select
Range("A2").PasteSpecial
Sheets("Tempsheet").Select
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
Sheets("Tempsheet").AutoFilterMode = False
If no data is returned by the filter then Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row) will return row 1, so test for row > 1 before doing the Delete
If Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).Row > 1 then
... .Delete
End If
Something like this code which tests for a filter result should do it
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Sheets("Tempsheet")
Set ws2 = Sheets("Excluded")
Set rng1 = ws.Range(ws.[a1], ws.Cells(Rows.Count, "k").End(xlUp))
rng1.AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
If rng1.SpecialCells(xlVisible).Rows.Count > 1 Then
ws.Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
ws.Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
ws2.[a2].PasteSpecial Paste:=xlPasteValues
rng1.Offset(1, 0).Resize(rng1.SpecialCells(xlVisible).Rows.Count - 1).EntireRow.Delete
End If
Sheets("Tempsheet").AutoFilterMode = False
Sheets("Tempsheet").Select
Range("A1:K1").AutoFilter
Range("A1:K1").AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
Sheets("Excluded").Select
Range("A2").PasteSpecial
Sheets("Tempsheet").Select
if Range("A" & Rows.Count).End(xlUp).Row > 1 then
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
end if
Sheets("Tempsheet").AutoFilterMode = False