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
Related
This code worked once and then stopped. It runs with no action or errors.
I would like if column "a" of the "export" sheet has a yes to copy the cells from B to J to the next clear line in workbook MOSTEST sheet1 (named 11.2022).
Sub DateSave()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 1).Value = "YES" Then
Range(Cells(i, 2), Cells(i, 10)).Select
Selection.Copy
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx"
Worksheets("11.2022").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
If changed the "Worksheets("11.2022").Select" to sheet1 which I would prefer as I wouldn't have to change it every month.
You should try to avoid using select, see other post
I adjusted your code where needed, I'm still trying to figure out best practice (i.e. it would be better adding the cell ranges to a range variable and then pasting them in one go but I'm not quite there yet) when it comes to minimizing code so if others can do better, feel free :)
Sub DateSave()
Dim LastRow As Long, i As Long, erow As Long
Dim wsStr As String
Dim ws As Worksheet, wsC As Worksheet
Dim wb As Workbook, wbM As Workbook
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
Set wb = ActiveWorkbook
Set wsC = wb.Sheets("EXPORT")
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx" 'Don't keep opening and saving/closing your workbook per copy, that would heavily increase runtime
Set wbM = Workbooks("MOSTEST.xlsx")
wsStr = Month(Date) & "." & Year(Date)
Set ws = wbM.Worksheets(wsStr) 'If your currentmonth will always be the first sheet then you can use wbM.Sheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Row
wb.Activate
For i = 1 To LastRow
If wsC.Cells(i, 1).Value = "YES" Then
erow = erow + 1
wsC.Range(wsC.Cells(i, 2), wsC.Cells(i, 10)).Copy 'avoid select
ws.Range("A" & erow).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next i
wbM.Save
wbM.Close
Application.CutCopyMode = False
End Sub
If you have questions, feel free to ask!
I have an excel macro that is running correctly on over 10 pc's.
On 1 pc it does not run correctly. It does not error out, just seems to not run to completion. All machines are running windows 10.
I have included the code below.
Fairly simple. Copies from "Follow_Up" sheet in the source file to "Sheet1" in the destination file.
It seems to stop just after it activates "Sheet1"
Sub copydata1()
Dim wbSrc As Workbook, wbDest As Workbook
Dim rngSrc As Range
Dim j As Integer
Dim i As Integer
Set wbSrc = ActiveWorkbook
Sheets("Follow_Up").Activate
Workbooks.Open "G:\Estimating Templates\Bid List_Lee.xlsm"
Set wbDest = ActiveWorkbook
Sheets("Sheet1").Activate
-----seems to stop here---------
Dim unusedRow As Long
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
j = ActiveCell.Row
j = unusedRow
MsgBox j
wbSrc.Activate
Sheets("Follow_Up").Select
Range("L151").Select
ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
Range("M151").Select
Range("A151:Q151").Select
Selection.Copy
wbDest.Activate
Sheet1.Cells(j, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheet1.Cells(j, 1) = Sheet1.Cells(j, 14)
Sheet1.Cells(j, 17).Select
ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1])"
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 1
Range("A20").Select
wbSrc.Activate
Sheets("Follow_Up").Select
Range("L151").Select
ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
Range("M151").Select
wbSrc.Activate
Sheets("Summary").Select
End Sub
Needed to write code for copy paste date in single column.
by means of that there are n numbers of columns and needed to paste those in single column.
code that i tried but not working well
Sub Macro4()
'
' Macro4 Macro
'
'
Range("C3").Select
Selection.Copy
Range("B4:B12").Select
ActiveSheet.Paste
Range("E3").Select
Application.CutCopyMode = False
Selection.Copy
Range("D4:D12").Select
ActiveSheet.Paste
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Range("F4:F8").Select
ActiveSheet.Paste
Range("I3").Select
Application.CutCopyMode = False
Selection.Copy
Range("H4:H10").Select
ActiveSheet.Paste
Range("B4:C12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D2").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("D4:E12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D11").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("F4:G8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D20").Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Range("H4:I10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet5").Select
Range("D25").Select
ActiveSheet.Paste
End Sub
i am posting image to show you which type of input i have and what type of output i needed. please help me to crack it ...Thanks
Welcome to StackOverflow. And welcome to VBA. Please study the code example below. it will do what you described.
Option Explicit ' always use this statement
Sub LoopColumns()
' always identify and declare your worksheets
Dim WsS As Worksheet ' Source sheet
Dim WsD As Worksheet ' Destination sheet
Dim CopyRange As Range
Dim C As Long ' column number
Dim Rld As Long ' last row in WsD
Set WsS = ActiveSheet ' better identify the sheet by name
Set WsS = Worksheets("Sheet1") ' this is the sheet I used
Set WsD = Worksheets("Sheet5") ' better give the sheet a descriptive name
For C = 1 To 6 Step 2 ' select columns 1, 3 and 5 in turn
' specify the range starting in row 4 of the looped column
' and end at the end of that column, offset by 1
Set CopyRange = WsS.Range(WsS.Cells(4, C), _
WsS.Cells(WsS.Rows.Count, C).End(xlUp).Offset(0, 1))
' determine the row below the last used row in WsD
Rld = WsD.Cells(WsD.Rows.Count, 1).End(xlUp).Row + 1
If Rld < 3 Then Rld = 3 ' start from row 3 3
' paste to column A below the last used row
CopyRange.Copy Destination:=WsD.Cells(Rld, "A")
Next C
End Sub
Change the ranges and try:
Option Explicit
Sub test()
Dim LastRowCol As Long, LastRowOut As Long, i As Long, StartColumn As Long, Endcolumn As Long
StartColumn = 2
Endcolumn = 6
With ThisWorkbook.Worksheets("Sheet1")
For i = StartColumn To Endcolumn Step 2
LastRowCol = .Cells(.Rows.Count, i).End(xlUp).Row
LastRowOut = .Cells(.Rows.Count, "J").End(xlUp).Row
.Range(.Cells(4, i), .Cells(LastRowCol, i + 1)).Copy .Range("J" & LastRowOut + 1)
Next i
End With
End Sub
Result:
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:
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