The code below works well apart from the specific element:
rowstopasteperiodsWks.Range(("A14"), ActiveCell.Offset(-pasteCount, 0)).Copy_
Destination:=Worksheets("Input").Range(LastRowPeriod,Offset(-pasteCount,0))
I am trying to copy a range of cells (A14 and a specified (n) number of cells above this cell) from the RowsToPaste sheet and paste this range to the Input sheet to the last cell in the row of column D (so that the last row in column D will have A14 values, th second last will have A13 value etc.)
Thanks
FULL CODE:
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Data")
Set rowstopasteperiodsWks = Worksheets("RowsToPaste")
Dim lng As Long
Dim pasteCount As Long
pasteCount = Worksheets("RowsToPaste").Cells(2, 6)
periodsCopy = Worksheets("RowsToPaste").Range("A12")
LastRowPeriod = Cells(Rows.Count, 4).End(xlUp).Row
oCol = 3 ' staff info is pasted on data sheet, starting in this column
rowstopasteperiodsWks.Range(("A14"), ActiveCell.Offset(-pasteCount, 0)).Copy_
Destination:=Worksheets("Input").Range(LastRowPeriod,Offset(-pasteCount,0))
'check for duplicate staff number in database
If inputWks.Range("CheckAssNo") = True Then
lRsp = MsgBox("Order ID already in database. Update record?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Order ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("Entry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
For lng = 1 To pasteCount
With .Cells(nextRow + lng, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow + lng, "B").Value = Application.UserName
'copy the data and paste onto data sheet
myCopy.Copy
.Cells(nextRow + lng, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next lng
Application.CutCopyMode = False
End With
'clear input cells that contain constants
ClearDataEntry
End If
End Sub
if you have to copy cell "A14" and pasteCount more cells above it:
rowstopasteperiodsWks.Range("A14").Offset(-pasteCount).Resize(pasteCount + 1).Copy _
Destination:=Worksheets("Input").Cells(Rows.Count, "D").End(xlUp).Offset(1)
if you have to copy pasteCount cells starting from "A14" upwards:
rowstopasteperiodsWks.Range("A14").Offset(-pasteCount+1).Resize(pasteCount).Copy _
Destination:=Worksheets("Input").Cells(Rows.Count, "D").End(xlUp).Offset(1)
Just noticed one obvious error.
Fix it and try again::
rowstopasteperiodsWks.Range(("A14"), ActiveCell.Offset(pasteCount*-1, 0)).Copy_
Destination:=Worksheets("Input").Range(LastRowPeriod,Offset(pasteCount*-1,0))
Related
I am trying to copy my data depending on the column value. If column R has invalid, then it should copy all information from sheet1 to sheet2.
I have below code running. Due to some reason it does not copy the last two rows of my sheet1.
I have 551 rows in sheet1 , and I have the 551 row column R as invalid. 'It checks only till 548 rows and skips the last row without moving them.
Could someone help me to fix this issue
Sub Tab()
Dim cell As Range
Dim nextrow As Long
Dim a As Double
Application.ScreenUpdating = False
' get the count of rows in column r
a = Sheets("sheet1").Cells(Rows.count, "R").End(xlUp).Row
MsgBox (a)
For Each cell In Sheets("sheet1").Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
nextrow = Application.WorksheetFunction.CountA(Sheets("sheet2").Range("R:R"))
Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
End If
Next
Application.ScreenUpdating = True
End Sub
Instead of
Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
try
Sheets("sheet1").Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
Your code can be written as
Sub Demo()
Dim cell As Range
Dim nextrow As Long, a as Long
Dim srcSht As Worksheet, destSht As Worksheet
Application.ScreenUpdating = False
Set srcSht = ThisWorkbook.Sheets("Sheet3")
Set destSht = ThisWorkbook.Sheets("Sheet6")
nextrow = Application.WorksheetFunction.CountA(destSht.Range("R:R"))
With srcSht
a = .Cells(.Rows.Count, "R").End(xlUp).Row
MsgBox a
For Each cell In .Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
.Rows(cell.Row).Copy Destination:=destSht.Range("A" & nextrow + 1)
nextrow = nextrow + 1
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Also instead of pasting data row by row you can also use UNION.
I will not go into the part on the variables and methodology (everyone has their way of scripting). I will respond based on your base code above, hopefully it is clear for your understanding.
Sub Tab()
Dim cell As Range
Dim nextrow As Long
Dim a As Double
Application.ScreenUpdating = False
' get the count of rows in column r
a = Sheets("sheet1").Cells(Rows.count, "R").End(xlUp).Row
MsgBox (a)
'This is assuming that you will always populate starting from the first row Range("A1") in Sheet2
nextrow = 1
For Each cell In Sheets("sheet1").Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
'Use the EntireRow function to copy the whole row to the Sheet2.
'During the next iteration, it will +1 to nextrow, so the next record will be copied to Range("A2"), next Range("A3") and so forth.
cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("a" & nextrow)
nextrow = nextrow + 1
End If
Next
Application.ScreenUpdating = True
End Sub
The code below copies data (Associate Entry named range) and pastes it into the particular row number (1RecRow) in a different sheet (AssociateData).
I would like the row to be pasted to all the rows ONLY BELOW the numbered row.
There are a couple of things to bear in mind:
A. The data is filtered and I would like the pasting to affect rows below "1 RecRow" within the filtered view (not ALL - unfiltered - data).
B. If it helps, the data is sorted in a way if the "1 RecRow" is 23, then the next row is 24, 25, 26, 27 (in order).
So manually I would do it in this way: Paste the data in the particular row, copy the data again from 1 RecRow, Ctrl+Shift+Down arrow and Paste. I'm just not sure how to adjust the code so that it performs it.
Thanks
Sub UpdateLogRecord()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim lRec As Long
Dim oCol As Long
Dim lRecRow As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("AssociateData")
oCol = 3 'associate info is pasted on data sheet, starting in this column
'check for duplicate order ID in database
If inputWks.Range("CheckAssNo") = False Then
lRsp = MsgBox("Order ID not in database. Add record?", vbQuestion + vbYesNo, "New Order ID")
If lRsp = vbYes Then
UpdateLogWorksheet
Else
MsgBox "Please select Order ID that is in the database."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("AssociateEntry")
lRec = inputWks.Range("CurrRec").Value
lRecRow = lRec + 1
With inputWks
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(lRecRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(lRecRow, "B").Value = Application.UserName
myCopy.Copy
.Cells(lRecRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
ClearDataEntry
End If
End Sub
Giving this a try... you would specify visible cells to not overwrite the hidden items.
Dim LR As Long
LR = Cells(Sheets("AssociateData").Rows.Count, 1).End(xlUp).Row
myCopy.Copy
.Range(Cells(lRecRow, 3), Cells(LR,3)).SpecialCells(xlCellTypeVisible).PasteSpecial xlValues
Application.CutCopyMode = False
That should paste over the defined range. I think it would be better than FillDown... which would look like:
.Range(Cells(lRecRow, 3),Cells(LR,3)).FillDown
If you want to filldown, you would put that in directly after you have pasted the value/formula.
I want to copy a table into a new Workbook while choosing which range I want to copy and knowing that the first Columns ("A") is automatically copied. (rows are not a problem, all of them have to be copied)
For example, i have a table composed of 28 rows and 10 columns. Added to A1:A28 (first columns, all rows),i want just to copy the column 5 and 8 with all its rows.
That's what i have until now but it doesn't work.
Sub CommandButton1_Click()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet
Dim CurrCols As Variant
Dim rng As rang
'Copy the data you need
Set currentWB = ThisWorkbook
Set currentS = currentWB.Sheets("Feuil1")
'select which columns you want to copy
CurrCols = InputBox("Select which column you want to copy from table (up to 10)")
If Not IsNumeric(CurrCols) Then
MsgBox "Please select a valid Numeric value !", vbCritical
End
Else
CurrCols = CLng(CurrCols)
End If
'Set rng = currentWB.currentS.Range(Cells(1, A), Cells(27, CurrCols)).Select
currentS.Range("A1:A27").Select
Selection.copy
Set rng = currentWB.currentS.Range(Cells(1, CurrCols), Cells(28, CurrCols)).Select
rng.copy
'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Feuil1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
Can you help please solving it? Thanks in advance!
You can't copy a non-continuous range but you can load the data into an array and write it once to the new workbook.
Private Sub CommandButton1_Click()
Dim arData
Dim MyColumns As Range, Column As Range
Dim x As Long, y As Long
On Error Resume Next
Set MyColumns = Application.InputBox(Prompt:="Hold down [Ctrl] and click the columns to copy", Title:="Copy Columns to new Workbook", Type:=8)
On Error GoTo 0
If MyColumns Is Nothing Then Exit Sub
Set MyColumns = Union(Columns("A"), MyColumns.EntireColumn)
Set MyColumns = Intersect(MyColumns, ActiveSheet.UsedRange)
ReDim arData(1 To MyColumns.Rows.Count, 1 To 1)
For Each Column In MyColumns.Columns
y = y + 1
If y > 1 Then ReDim Preserve arData(1 To MyColumns.Rows.Count, 1 To y)
For x = 1 To Column.Rows.Count
arData(x, y) = Column.Rows(x)
Next
Next
With Workbooks.Add().Worksheets(1)
.Range("A1").Resize(UBound(arData, 1), UBound(arData, 2)) = arData
.Columns.AutoFit
End With
End Sub
try this (commented) code
Option Explicit
Sub CommandButton1_Click()
Dim newSht As Worksheet
Dim currCols As String
Dim area As Range
Dim iArea As Long
Set newSht = Workbooks.add.Worksheets("Feuil1") '<--| add a new workbook and set its "Feuil1" worksheet as 'newSht'
currCols = Replace(Application.InputBox("Select which column you want to copy from table (up to 10)", "Copy Columns", "A,B,F", , , , , 2), " ", "") '<--| get columns list
With ThisWorkbook.Worksheets("Feuil1") '<--| reference worksheet "Feuil1" in the workbook this macro resides in
For Each area In Intersect(.Range(ColumnsAddress(currCols)), .Range("A1:G28")).Areas ' loop through referenced worksheet areas of the range obtained by crossing its listed columns with its range "A1:G28"
With area '<--| reference current area
newSht.Range("A1").Offset(, iArea).Resize(.Rows.Count, .Columns.Count).value = .value '<--| copy its values in 'newSht' current column offset from "A1" cell
iArea = iArea + .Columns.Count '<--| update current column offset from 'newSht' worksheet "A1" cell
End With
Next area
End With
End Sub
Function ColumnsAddress(strng As String) As String
Dim elem As Variant
For Each elem In Split(strng, ",")
ColumnsAddress = ColumnsAddress & elem & ":" & elem & ","
Next
ColumnsAddress = Left(ColumnsAddress, Len(ColumnsAddress) - 1)
End Function
I think you can copy all column to a temp sheet and then write some code to delete the useless column. finally paste the table to your expected area.
Below are my codes, I am trying to force the checking to start from the first cell, but it doesn't work. Can anyone advise me on that. Thanks
I am trying to do checking on the names which is on the 3rd column of Workbook A and compare it with the other column in another workbook. Upon match of the string, it will copy certain cells to the desalinated column
Sub copyandpaste()
Set From_WS = Workbooks("copy_data2").Worksheets("Data")
Set To_WS = Workbooks("Book1").Worksheets("Sheet1")
Dim v1 As String
Dim v2 As String
Dim diffRow As Long
Dim dataWs As Worksheet
Dim copyWs As Worksheet
Dim rowData As Long
Dim totRows As Long
Dim lastRow As Long
Dim result As String
Dim row_no As Integer
Dim Name As Range
Dim Namelist As Range
diffRow = 1 'compare
Set dataWs = Worksheets("Data")
Set copyWs = Worksheets("Diff")
For Each c In Worksheets("Data").Range("C2:C10")
If c.Value <> "" Then
v1 = c
End If
For Each d In Workbooks("Book1").Worksheets("Sheet1").Range("B2:B10")
If d.Value <> "" Then
v2 = d
End If
With From_WS.Cells(1, 2).CurrentRegion
Total_Rows = .Rows.Count
Total_Columns = .Columns.Count
End With
Set mycellA = From_WS.Range("C:C")
Set mycellB = To_WS.Range("B:B")
Copy = False
' With Sheets("copy_data2")
' lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'find first row
'column1 = Range("A2").End(xlToRight).Column
'For row_no = 1 To 10
'=========================================================================
Set Namelist = dataWs.Range("A1:A" & dataWs.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
'For Each Name In Namelist.Cells
mynumber = 1
For Each Name In Namelist
'=======================================================================
If v1 = v2 Then
'select sheet
Sheets("Data").Select
'ActiveCell.Select 'select active cell
ActiveCell.Interior.ColorIndex = 36 'color the cell
'copy active cell same row
ActiveCell.Range("A1:F1").Copy
ActiveCell.Interior.ColorIndex = 50 'color the cell
'Paste file destination
Sheets("Diff").Select
Sheets("Diff").Range("A2").Select
'Paste Active
ActiveSheet.Paste
ActiveCell.Interior.ColorIndex = 37 '<< Colored Blue
'==================================================================
'select sheet
Sheets("Data").Select
'ActiveCell.Select 'select active cell
ActiveCell.Interior.ColorIndex = 36 'color cell Yellow
'result = ActiveCell.EntireRow.copy
'copy active cell same row
ActiveCell.Range("H1:J1").Copy
'Paste file destination
Sheets("Diff").Select
'Paste cell destination
Sheets("Diff").Range("G2").Select
'Paste Active
ActiveSheet.Paste
mynumber = mynumber + 1
End If
Next Name
Next d
Next c
End Sub
This is the second function, to count and go through the rows.
Sub RoundToZero1()
For Counter = 1 To 20
Set curCell = Worksheets("Data").Cells(Counter, 3)
If Abs(curCell.Value) < 0.01 Then curCell.Value = 0
Next Counter
End Sub
Update Question:
I have the code below, I need to make the column A to be incremental. Anyone have suggestion how to achieve that?
Sheets("Diff").Range("A").Select
The line Set selectedCell = selectedCell + 1 throws an error when I run it and doesn't appear to do anything in the code, if that is the case you should comment it out or delete it.
Also I think you need to change
Else
If IsEmpty(Cells(i, 1)) = True Then 'if cells in column "A" is empty then stop
to
ElseIf IsEmpty(Cells(i, 1)) = True Then 'if cells in column "A" is empty then stop
As it stands you have an extra open If statement.
I am facing some difficulty in achieving the desired result for my macro.
Intention:
I have a list of data in sheets(input).column A (the number of rows that has value will vary and hence I created a loop that will run the macro until the activecell is blank).
My macro starts from Range(A2) and stretches all the way down column A, it stops only when it hits a blank row
Desired result for the macro will be to start copying the cell value in sheet(input).Range(A2) paste it to sheet(mywork).Range(B2:B6).
For example, if "Peter" was the value in cell sheet(input),range(A2) then when the marco runs and paste the value into sheet(mywork) range(B2:B6). ie range B2:B6 will reflect "Peter"
Then the macros loop back to sheet(input) & copy the next cell value and paste it to range(B7:B10)
Example: "Dave" was the value in sheet(input) Range(A3), then "Dave" will be paste into the next 4 rows in sheet(mywork).Range(B7:B10). B7:B10 will reflect "Dave"
Again repeating the same process goes back to sheet(input) this time range(A4), copys the value goes to sheet(mywork) and paste it into B11:B15.
Basically the process repeats....
The macro ends the when the activecell in sheet(input) column A is empty.
Sub playmacro()
Dim xxx As Long, yyy As Long
ThisWorkbook.Sheets("Input").Range("A2").Activate
Do While ActiveCell.Value <> ""
DoEvents
ActiveCell.Copy
For xxx = 2 To 350 Step 4
yyy = xxx + 3
Worksheets("mywork").Activate
With ActiveSheet
.Range(Cells(xxx, 2), Cells(yyy, 2)).PasteSpecial xlPasteValues
End With
Next xxx
ThisWorkbook.Sheets("Input").Select
ActiveCell.Offset(1, 0).Activate
Loop
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim Z As Long
Dim Cellidx As Range
Dim NextRow As Long
Dim Rng As Range
Dim SrcWks As Worksheet
Dim DataWks As Worksheet
Z = 1
Set SrcWks = Worksheets("Sheet1")
Set DataWks = Worksheets("Sheet2")
Set Rng = EntryWks.Range("B6:ad6")
NextRow = DataWks.UsedRange.Rows.Count
NextRow = IIf(NextRow = 1, 1, NextRow + 1)
For Each RA In Rng.Areas
For Each Cellidx In RA
Z = Z + 1
DataWks.Cells(NextRow, Z) = Cellidx
Next Cellidx
Next RA
End Sub
Alternatively
Worksheets("Sheet2").Range("P2").Value = Worksheets("Sheet1").Range("L10")
This is a CopynPaste - Method
Sub CopyDataToPlan()
Dim LDate As String
Dim LColumn As Integer
Dim LFound As Boolean
On Error GoTo Err_Execute
'Retrieve date value to search for
LDate = Sheets("Rolling Plan").Range("B4").Value
Sheets("Plan").Select
'Start at column B
LColumn = 2
LFound = False
While LFound = False
'Encountered blank cell in row 2, terminate search
If Len(Cells(2, LColumn)) = 0 Then
MsgBox "No matching date was found."
Exit Sub
'Found match in row 2
ElseIf Cells(2, LColumn) = LDate Then
'Select values to copy from "Rolling Plan" sheet
Sheets("Rolling Plan").Select
Range("B5:H6").Select
Selection.Copy
'Paste onto "Plan" sheet
Sheets("Plan").Select
Cells(3, LColumn).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
LFound = True
MsgBox "The data has been successfully copied."
'Continue searching
Else
LColumn = LColumn + 1
End If
Wend
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
And there might be some methods doing that in Excel.