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
Related
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 a sumif statement that uses 11 criterias. It works with all criterias that have text in them, but it fails to work when I add a field that has blanks and/or numbers in it. I can't figure out how to overcome this problem and would like some help. Here is my code:
Dim GS As Worksheet
Set GS = Worksheets("Grant Spreadsheet")
Dim LastRow As Long
With GS
LastRow = GS.Range("W1000").End(xlUp).Row
Me.TGATxtBx.Value = WorksheetFunction.SumIfs(.Range("w2:w" & LastRow),_
.Range("e2:e" & LastRow), "*" & Me.GrantNameCmboBx.Value & "*",_
.Range("n2:n" & LastRow), "*" & Me.GrantAgencyCmboBx.Value & "*",_
.Range("o2:o" & LastRow), "*" & Me.GrantDeptCmboBx.Value & "*",_
.Range("p2:p" & LastRow), "*" & Me.ProgramCmboBx.Value & "*",_
.Range("d2:d" & LastRow), "*" & Me.ProjTypeCmboBx.Value & "*",_
.Range("r2:r" & LastRow), "*" & Me.CatalogNoCmboBx.Value & "*",_
.Range("q2:q" & LastRow), "*" & Me.PassthroughCmboBx.Value & "*",_
.Range("s2:s" & LastRow), "*" & Me.GrantIDCmboBx.Value & "*",_
.Range("h2:h" & LastRow), "*" & Me.FundNoCmboBx.Value & "*"_
.Range("i2:i" & LastRow), "*" & Me.OrgTxtBx.Value & "*",_
.Range("k2:k" & LastRow), "*" & Me.AccountTxtBx.Value & "*")
Me.PassthroughCmboBx.Value has blanks and the three fields after that have numbers. If I move things around and bring these fields in earlier between the criterias that do work, it fails. I could really use your help.
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 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
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