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
Related
I want to write a code similar to UDF where I hardcode a function and then create parameters for it for the code below. This is for opening an excel file and from external workbook and copy pasting the values from certain columns to the active workbook.
Private Sub Btn_Load_Test_Data_file_Click()
Dim FileLocation As String
Dim LastRow As Long
Dim wb As Workbook
Set wb = ActiveWorkbook
FileLocation = Application.GetOpenFilename
If FileLocation = "False" Then
Beep
Exit Sub
End If
Application.ScreenUpdating = False
Set ImportWorkbook = Workbooks.Open(Filename:=FileLocation)
LastRow = ImportWorkbook.Worksheets("Projects").Range("A7").End(xlDown).row
curr_lrow = wb.Worksheets("Projects").Range("A5").End(xlDown).row
'Copy range to clipboard
ImportWorkbook.Worksheets("Projects").Range("B7", "B" & LastRow).Copy
'PasteSpecial to paste values, formulas, formats, etc.
wb.Worksheets("Projects").Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("C7", "C" & LastRow).Copy
wb.Worksheets("Projects").Range("C" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("D7", "D" & LastRow).Copy
wb.Worksheets("Projects").Range("E" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("E7", "E" & LastRow).Copy
wb.Worksheets("Projects").Range("F" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("F7", "F" & LastRow).Copy
wb.Worksheets("Projects").Range("G" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("G7", "G" & LastRow).Copy
wb.Worksheets("Projects").Range("H" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("H7", "H" & LastRow).Copy
wb.Worksheets("Projects").Range("I" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("I7", "I" & LastRow).Copy
wb.Worksheets("Projects").Range("J" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("J7", "J" & LastRow).Copy
wb.Worksheets("Projects").Range("K" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("K7", "K" & LastRow).Copy
wb.Worksheets("Projects").Range("L" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("L7", "L" & LastRow).Copy
wb.Worksheets("Projects").Range("M" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("M", "M" & LastRow).Copy
wb.Worksheets("Projects").Range("N" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("N7", "N" & LastRow).Copy
wb.Worksheets("Projects").Range("O" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("O7", "O" & LastRow).Copy
wb.Worksheets("Projects").Range("P" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("P7", "P" & LastRow).Copy
wb.Worksheets("Projects").Range("Q" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("Q7", "Q" & LastRow).Copy
wb.Worksheets("Projects").Range("R" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("R7", "R" & LastRow).Copy
wb.Worksheets("Projects").Range("BL" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("S7", "S" & LastRow).Copy
wb.Worksheets("Projects").Range("BM" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("T7", "T" & LastRow).Copy
wb.Worksheets("Projects").Range("BN" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("U7", "U" & LastRow).Copy
wb.Worksheets("Projects").Range("BO" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("V7", "V" & LastRow).Copy
wb.Worksheets("Projects").Range("BP" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("W7", "W" & LastRow).Copy
wb.Worksheets("Projects").Range("BQ" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("X7", "X" & LastRow).Copy
wb.Worksheets("Projects").Range("BR" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("Y7", "Y" & LastRow).Copy
wb.Worksheets("Projects").Range("BS" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("Z7", "Z" & LastRow).Copy
wb.Worksheets("Projects").Range("BT" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("AA7", "AA" & LastRow).Copy
wb.Worksheets("Projects").Range("BU" & LastRow).PasteSpecial Paste:=xlPasteValues
ImportWorkbook.Worksheets("Projects").Range("AB7", "AB" & LastRow).Copy
wb.Worksheets("Projects").Range("BV" & LastRow).PasteSpecial Paste:=xlPasteValues
End Sub
Try something like this:
Private Sub Btn_load_data_file_Click()
Dim FileLocation As String
Dim LastRow As Long, wsPaste As Worksheet, curr_lrow As Long
Dim wb As Workbook, ImportWorkbook As Workbook, wsImport As Worksheet
FileLocation = Application.GetOpenFilename
If FileLocation = "False" Then
Beep
Exit Sub
End If
Set wb = ActiveWorkbook
Set wsPaste = wb.Worksheets("Projects")
Application.ScreenUpdating = False
Set ImportWorkbook = Workbooks.Open(Filename:=FileLocation)
Set wsImport = ImportWorkbook.Worksheets("Projects")
LastRow = wsImport.Cells(Rows.Count, "A").End(xlUp).Row + 1 'safer than .End(xlDown)...
curr_lrow = wsPaste.Cells(Rows.Count, "A").End(xlUp).Row + 1
CopyValues wsImport.Range("B7:B" & LastRow), wsPaste.Range("A" & curr_lrow)
CopyValues wsImport.Range("C7:C" & LastRow), wsPaste.Range("C" & curr_lrow)
ImportWorkbook.Close False
End Sub
'Copy values from `rngFrom` to `rngTo`
Sub CopyValues(rngFrom As Range, rngTo As Range)
With rngFrom
rngTo.Cells(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End Sub
I currently have this code that works to insert full rows. However, I was hoping to limit the inserting of the row to columns A:J.
Bonus points to see who can help me figure out that if I delete column C why my current code doesn't work?
I tried to add .resize(1,10) but for some reason I keep getting errors, maybe the location in which I try to add this function. Any guidance/help is appreciated as always!
Here is my current code:
VBA Code:
Sub Add_Job()
Dim act As Worksheet
Set act = ThisWorkbook.ActiveSheet
bot_row = act.Range("Z1")
act.Rows(bot_row & ":" & bot_row + (5)).Insert Shift:=x1ShiftDown
act.Range("A3:J8").Copy
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormats
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormulas
Range("B" & bot_row & ":B" & bot_row + (5)).ClearContents
Application.CutCopyMode = False
End Sub
Edit: Updated Code that works now. However, I still don't understand if I delete column C, why it throws an error?
Dim act As Worksheet
Set act = ThisWorkbook.ActiveSheet
bot_row = act.Range("Z1")
act.Range("A" & bot_row & ":J" & bot_row + (5)).Insert Shift:=xlShiftDown
act.Range("A3:J8").Copy
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormats
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormulas
Range("B" & bot_row & ":B" & bot_row + (5)).ClearContents
Application.CutCopyMode = False
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