With Excel VBA, I would like to have a button which adds a new 'Feature #' column before the 'Total' column, every time the button is pressed.
Basically, a button that does the following, from image 1 -> 2 -> 3.
1.
2.
3.
Update:
Assuming your Table is from Cell A2 try the following:
Sub InsertColumn()
Dim lastColumn As Long, lastRow As Long
lastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Columns(lastColumn - 1).Select
Range(Selection, Selection).Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Application.CutCopyMode = False
Cells(2, lastColumn).Value = "Feature" & " " & lastColumn - 1
Range(Cells(3, lastColumn), Cells(lastRow, lastColumn)).ClearContents
Cells(1, 1).Select
End Sub
EDIT:
_________________________________________________________________________________
This code should work for updated question or the image added.
Sub InsertColumn111()
Dim lastColumn As Long, lastRow As Long
Dim rConstants As Range
lastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
lastRow = Range("A1").End(xlDown).Row
Columns(lastColumn - 1).Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Application.CutCopyMode = False
Cells(2, lastColumn).Value = "Feature" & " " & lastColumn - 1
Range(Cells(3, lastColumn), Cells(lastRow, lastColumn)).ClearContents
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(lastRow - 1).Select
Selection.Copy
Selection.Insert Shift:=xlToBottom
Application.CutCopyMode = False
Cells(lastRow, 1).Value = "Feature" & " " & lastRow - 7
Set rConstants = Range(Cells(lastRow, 2), Cells(lastRow, lastColumn)).SpecialCells(xlCellTypeConstants)
rConstants.ClearContents
Cells(1, 1).Select
End Sub
Assuming data starting with A1 (Pls. refer the image below)
Sub Button1_Click()
columntoinsert = Cells(1, 1).End(xlToRight).Column
Columns(columntoinsert).Insert
Cells(1, columntoinsert) = "Feature" & columntoinsert - 1
End Sub
After the button click:
Related
I am new to macros. I have this below code in which I am trying to copy some filtered data from one sheet and paste in another worksheet in the end but getting error in the pasting step. I dont know how to correct that. Can someone please help me on this?
Sub MyTest()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim r As Long
Dim str As String
Dim lRow As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
lr1 = Cells(Rows.Count, 3).End(xlUp).Row
lr2 = Cells(Rows.Count, 2).End(xlUp).Row
For r = lr1 To 5 Step -1
ws2.Activate
str = ws2.Cells(r, "C")
i = Application.WorksheetFunction.CountIf(ws1.Columns(1), str)
If i > 1 Then ws2.Rows(r + 1 & ":" & r + i - 1).Insert
ws2.Range(Cells(r, "C"), Cells(r + i - 1, "C")) = str
ws2.Activate
ws2.Range("$A$4:$W$4").AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:=str
ws1.Activate
ws1.Range("$A$1:$D$1").AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=str
ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Copy
ws2.Activate
ws2.Range("$A$4:$W$4").AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:=str
ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 8).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Next r
End Sub
Struggle with this code below.
What I am trying to achieve is I have a purchase order form which when one is generated I would like to be able to copy certain cells to a purchase order log on a different sheet.
Currently I have this code
Sub Range_PasteSpecial_Values1()
Worksheets("Sheet1").Range("A1").Copy
Worksheets("Sheet2").Range("A10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("B1").Copy
Worksheets("Sheet2").Range("B10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("C1").Copy
Worksheets("Sheet2").Range("C10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("D1").Copy
Worksheets("Sheet2").Range("D10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("E1").Copy
Worksheets("Sheet2").Range("E10").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet1").Range("F1").Copy
Worksheets("Sheet2").Range("F10").PasteSpecial Paste:=xlPasteValues
End Sub
Which works but it does copy these cells into the row below in my purchase orders log.
Hope this is clear and thanks for your help
Public Sub CopyRows()
Sheets("Sheet1").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 4).Value
If ThisValue = "A" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("SheetA").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ElseIf ThisValue = "B" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("SheetB").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next x
End Sub
why twb cells(i,7) value don't show up in the extwb(pasterowIndex, 1)?
can you make this
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
code little simple, because I have many value to copy?
Sub historical()
Dim twb As Workbook
Dim extwb As Workbook
Dim extwb3 As Worksheet
Dim i As Long
Dim pasterowIndex As Long
pasterowIndex = 2
Set twb = Workbooks.Open("C:\Users\faisal.abraham\Documents\Travel\PUPD.xlsx")
Set extwb = Workbooks.Open("C:\Users\faisal.abraham\Documents\Travel\PIRD.xlsx")
With twb.Sheets("Actuary_Travel_Voucher_Engineer")
For i = 8 To Cells(Rows.Count, 1).End(xlUp).Row
If twb.Cells(i, 23).Value = "PERMATA HIJAU " And Cells(i, 28).Value = "PAID" Then
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
pasterowIndex = pasterowIndex + 1
End If
Next i
pasterowIndex = 2
End With
End Sub
This code
twb.Sheets(1).Activate
Cells(i, 7).Select
Selection.Copy
extwb.Sheets(8).Activate
Cells(pasterowIndex, 1).Select
ActiveSheet.Paste
can be replaced with
twb.Sheets(1).cells(i,7).copy extwb.sheets(8).cells(pasteindex,1)
Which doesn't fix the other issues but at least makes the code less painful
Below mentioned code works well with "Workbook_BeforeSave"but I realized, that if user press save twice code paste the walues twice. So I need to run "remove duplicates" just before closing the Proposal_Admin.xlsm after last paste. Could you please kindly help me about that.
Thanks & Regards.
Sub CopyToOtherCell()
Dim LastRow As Long, i As Integer, erow As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 12).Value = Date Then
Range(Cells(i, 1), Cells(i, 12)).Select
Selection.Copy
Workbooks.Open Filename:="C:\Users\Murat\Documents\Teklifler\Proposal_Admin.xlsm"
ActiveWorkbook.Sheets("AdminSheet").Activate
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(erow, 1).Offset(1, 0).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
Can you not just look to see if the workbook has been saved?
If ThisWorkbook.Saved then
'Blah blah...
end if
I know a bit of VBA, however I got a problem, I am trying to write a code that will copy all data from 1 sheet, append/paste it into the next blank cell in sheet 2 and then remove the data from sheet 1. I am using below code, but I get cell values replaced by the word TRUE.
Sub Instal_Sum_Paste()
ActiveWorkbook.Sheets("Vehicle working").Select
Dim N As Long
N = Cells(6, 2).End(xlDown).Row
Set DT = Range("b6:G" & N)
DT.Copy
ActiveWorkbook.Sheets("Installation Summary").Select
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
ActiveCell.Value = DT.PasteSpecial(xlPasteValues)
ActiveWorkbook.Sheets("Vehicle working").Select
DT.Select
Selection.ClearContents
MsgBox "done", vbOKOnly, "done"
End Sub
I managed to find an answer, its silly I know:
Sub Instal_Sum_Paste()
ActiveWorkbook.Sheets("Vehicle working").Select
Dim N As Long
N = Cells(6, 2).End(xlDown).Row
Set DT = Range("b6:G" & N)
DT.Select
Selection.Copy
ActiveWorkbook.Sheets("Installation Summary").Select
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
ActiveWorkbook.Sheets("Vehicle working").Select
DT.Select
Selection.ClearContents
MsgBox "done", vbOKOnly, "done"
End Sub