Appending data from one sheet to another Excel VBA - excel

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

Related

To add the excel formulas into VBA Macro with condition

I have recorded some formulas into Macros and they are functioning properly, however I am not able to update them so that they should select the range themselves where the data ends in the last end in Column C. These 3 formulas extracts Date, File Name and Status of Files from Column A. As you see for now the range is e.g. "F3 to F313" where next time if the Data in Column C is up to C500 Range than I have to manually copy and paste the formulas. Is there anyway these 3 formulas should automatically detect the last text cell from Column C and ends there. That would be much helpful.
To Extract Date
Sub Macro13() 'To Extract Date
ActiveCell.FormulaR1C1 = "=extractDate(RC[-1])"
Range("D2").Select
Selection.Copy
Range("D3:D313").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
To Find Status of File
Sub Macro15() 'To Find Status of File
ActiveCell.FormulaR1C1 = _
"=IFERROR(LOOKUP(2^15,SEARCH({""Feed"",""Feed 1"",""Feed 2""},RC[-3]),{""Feed"",""Feed 1"",""Feed 2""}),""Combine"")"
Range("F2").Select
Selection.Copy
Range("F3:F313").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
To extract File Name
Sub Macro17() 'To extract File Name
ActiveCell.FormulaR1C1 = _
"=IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABCD - GAMA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ALPHA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9," & _
"0},RC[-2]&""1234567890""))-1))=""ABCD - BETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""DBETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""A"",LEFT(RC[-2]," & _
"MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))="""",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABETA"",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),LEF" & _
"T(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2] & ""1234567890""))-1))))))))"
Range("E2").Select
Selection.Copy
Range("E3:E313").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

Try this:
Sub TestThis()
Dim LastRow As Long, ws As Worksheet
Set ws = ActiveSheet
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("D2:D" & LastRow).FormulaR1C1 = "=extractDate(RC[-1])"
ws.Range("F2:F" & LastRow).FormulaR1C1 = "=IFERROR(LOOKUP(2^15,SEARCH({""Feed"",""Feed 1"",""Feed 2""},RC[-3]),{""Feed"",""Feed 1"",""Feed 2""}),""Combine"")"
ws.Range("E2:E" & LastRow).FormulaR1C1 = _
"=IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABCD - GAMA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ALPHA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9," & _
"0},RC[-2]&""1234567890""))-1))=""ABCD - BETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""DBETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""A"",LEFT(RC[-2]," & _
"MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))="""",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABETA"",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),LEF" & _
"T(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2] & ""1234567890""))-1))))))))"
End Sub

how to calculate average for multiple tables of filtered data dynamically - VBA

I have a table where I need to find the elements present in different samples.
For every sample, the no of iterations is a variable - I can have two rows of sample 1 and 3 rows of sample2 or 5 rows of sample4. the number of columns which are the elements can also be different. I have considered 3 samples and 17 elements in this case.
I need to filter based on the sample. say sample 1. Then the average needs to be calculated for all the entries of sample 1. Then below that sample 2 values need to be displayed and the average for all the entries of sample 2 should be calculated.
I am a beginner in vba and hence the code I used is not able to do it for dynamic range of values. Also, I can only calculate the average using macro recorder. I am not aware how to combine these two codes into one. I tried to search a lot on this topic
I have included my codes as well.
Any help would be much appreciated!!! Thank you
Sub sorttable()
Dim j As Long 'row variable
On Error GoTo Err_Execute
Dim i As Long
'Start search in row 1 in sheet1
j = 1
'Column counter for sheet2
i = 1
While Len(Range("A" & CStr(j)).Value) > 0
If Range("A" & CStr(j)).Value = "Sample1" Then
Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Cells(i, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Cells(j + 1, 1) = "=AVERAGE(A1:C" & j - 1 & ")" 'used to calculate avg
i = i + 1
Sheets("Sheet1").Select
ElseIf Range("A" & CStr(j)).Value = "Sample2" Then
Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Cells(i, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1
Sheets("Sheet1").Select
ElseIf Range("A" & CStr(j)).Value = "Sample3" Then
Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
Sheet2.Cells(i, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1
Sheets("Sheet1").Select
End If
j = j + 1
Wend
Application.CutCopyMode = False
MsgBox "the values have been extracted"
Exit Sub
Err_Execute:
MsgBox "Error Occured"
End Sub
'code- part of it for calculating the average
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("A9:B9"), Type:=xlFillDefault
Range("A9:B9").Select
Range("B9").Select
Selection.ClearContents
ActiveCell.FormulaR1C1 = "= AVERAGE(R[-2]C,R[-1]C)"
Range("B9").Select
Selection.AutoFill Destination:=Range("B9:R9"), Type:=xlFillDefault
Range("B9:R9").Select
Range("A11").Select
Sheets("Sheet2").Select
Range("A27").Select
Sheets("Sheet1").Select
Range("A8:R10").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A11").Select
ActiveSheet.Paste
Range("A14").Select
Application.CutCopyMode = False
Selection.Style = "Normal 2"
ActiveCell.FormulaR1C1 = "Average"
Range("B14").Select
ActiveCell.FormulaR1C1 = "= AVERAGE(R[-3]C:R[-1]C)"
Range("B14").Select
Selection.AutoFill Destination:=Range("B14:R14"), Type:=xlFillDefault
Range("B14:R14").Select
Range("A16").Select
End Sub

It looks like you've recorded your macro as a start, then tried to modify it from there. This is an excellent first step, so now there are things to be aware of:
The macro recorder captures many, many things that are unnecessary, so don't use Select or Activate.
Since your data may not be the same for each sample group, your code has to take that into account. Review the sample code below and notice that it loops to figure out how many rows are in a sample group, then dynamically fills in the formula for the columns of that group.
Option Explicit
Sub SortTable()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim numSampleRows As Long
numSampleRows = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row - 1
Dim sampleRow As Range
Set sampleRow = ws.Range("A2")
Dim i As Long
Dim numSamplesInGroup As Long
Dim currentSampleLabel As String
Dim numSampleColumns As Long
Dim avgRow As Long
Dim avgCol As Long
For i = 1 To (numSampleRows + 1)
'--- look at the sample labels to determine how
' many are in this group
If numSamplesInGroup = 0 Then
'--- this is the start of a sample group
currentSampleLabel = sampleRow.Offset(0, 0)
numSamplesInGroup = 1
ElseIf currentSampleLabel = sampleRow.Offset(0, 0) Then
'--- continue to count the samples in the group
numSamplesInGroup = numSamplesInGroup + 1
Else
'--- we've reached the end of the sample group
' so insert two empty rows here
sampleRow.EntireRow.Insert
sampleRow.EntireRow.Insert
Debug.Print sampleRow.Address
'--- create the AVERAGE formula for each populated column
' ASSUMES all the columns are consistent for each sample group
avgRow = sampleRow.Offset(-2, 0).Row
ws.Cells(avgRow, 1) = "Average"
numSampleColumns = ws.Cells(avgRow - 1, ws.Columns.Count).End(xlToLeft).Column
For avgCol = 1 To (numSampleColumns - 1)
sampleRow.Offset(-2, avgCol).FormulaR1C1 = _
"=AVERAGE(R" & _
avgRow - numSamplesInGroup & _
"C" & avgCol + 1 & _
":R" & avgRow - 1 & "C" & avgCol + 1 & ")"
Next avgCol
'--- reset for the next loop
currentSampleLabel = sampleRow.Offset(0, 0)
numSamplesInGroup = 0
End If
'--- move down one row
Set sampleRow = sampleRow.Offset(1, 0)
Next i
End Sub

Inserting a new column always before a certain heade

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:

automatically run "remove duplicates" on VBA

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

Paste copied stuff at the very end of a row

I have a form where you fill stuff in and a specific part of it should be copied to another sheet at the end of the list.
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastrow = .Cells(rows.Count, "B").End(xlUp).Row
Else
lastrow = 1
End If
.Cells(lastrow + 1, "B") = "my new value"
End With
I have this code to find the last row and paste/write "my new value" in it.
But i need that it pastes more than just one cell. I just need that it selects that part where it writes "my new value" in. I should be able to do the rest
I'm now using the code below. But it still copies stuff from the sheet "Tabelle3" but it should copy the stuff from the sheet "Tabelle2"
Private Sub CommandButton1_Click()
Dim lastRow As Long
With Sheets("Tabelle3")
If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Sheets("Tabelle2").Select
Range("B85:S85").copy
Sheets("Tabelle3").Select
'~~> Paste special
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub

You have to find the last empty row and then simply do a paste or pastespecial as shown below.
Sub Sample()
Dim lastRow As Long
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Range("Z10:Z100").Copy
'~~> Paste special
.Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub
The above code will copy the range "Z10:Z100" and do a pastespecial on the next available row in Col B. If you do not want to do a pastespecial and want to do a direct paste then see this
Sub Sample()
Dim lastRow As Long
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Range("Z10:Z100").Copy .Range("B" & lastRow)
End With
End Sub

Resources