I have an Excel sheet with names as one column and their working hours as values in next column.
I want to copy names with values greater than 40 to new sheet without any blanks in columns. The new sheet should have both names and the working hours; any text in the values column should be ignored.
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow1
If sh1.Cells(i, "F").Value > 20 Then
sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value
End If
Next i
End Sub
I would recommend using AutoFilter to copy and paste as it is faster than looping. See the example below.
My Assumptions
Original Data is in Sheet 1 as shown the snapshot below
You want the output in Sheet 2 as shown the snapshot below
CODE
I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long
'~~> Set the input sheet
Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")
'~~> Clear Sheet 2 for output
wsO.Cells.ClearContents
With wsI
'~~> Remove any existing filter
.AutoFilterMode = False
'~~> Find last row in Sheet1
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Filter Col B for values > 40
With .Range("A1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">40"
'~~> Copy the filtered range to Sheet2
.SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
End With
'~~> Remove any existing filter
.AutoFilterMode = False
End With
'~~> Inform user
MsgBox "Done"
End Sub
SNAPSHOT
Try rhis
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = 1
For i = 1 To lastrow1
If Val(sh1.Cells(i, "F").Value) > 20 Then
sh2.Range("A" & j).Value = sh1.Cells(i, "F").Value
j = j + 1
End If
Next i
End Sub
Related
I know this question is as old as time, but I am trying to copy data thats on an excel file, to another, based on multiple criteria.
The destination is called "Test.xlsm" and the source is called "Data.xlsx"
The idea would be for the code to identify the rows that have the text (1,3,D) on the column A, and copy the entire row to the Sheet1 on the destination Test.xlsm
The first row on Test.xlsm has a header so it has to be left alone when copying data to that sheet.
Both files have the destination and source info on sheets called "Sheet1" as default.
I found this code, but i cant adapt it to use a different worksheet for the source, though any code that does the goal is fine.
Sub Copy()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If Range("A" & r).Value = "1" Or Range("A" & r).Value = "3" Or Range("A" & r).Value = "D" Then
Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
You'll want to use Workbooks as well, since you are using separate ones, and then set the sheets like the example you provided.
For example:
Dim wkbk1 as Workbook, wkbk2 as Workbook, ws1 as WorkSheet, ws2 as Worksheet
Set wkbk1 = Workbooks.open("C:\path\to\Data.xlsx")
Set wkbk2 = Workbooks.open("C:\path\to\Test.xlsm")
Set ws1 = wkbk1.Sheets("Sheet1")
Set ws2 = wkbk2.Sheets("Sheet1")
From there you can use and modify the code you have.
edit: included OP's workbook and sheet names.
Try this edit or note where I've made edits based on the points in comments - I think this should do well!
Sub CopyThings()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Application.Workbooks("Data").Worksheets("Sheet1")
Set ws2 = Application.Workbooks("Test").WorkSheets("Sheet1")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If ws1.Range("A" & r).Value = "1" Or ws1.Range("A" & r).Value = "3" Or ws1.Range("A" & r).Value = "D" Then
ws1.Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
I don't know why I am having the hardest time with this. I am just trying to copy a single row from sheet1 to the next available row on sheet2. I have to row copied but it just wont paste without giving me error. This is my copy and it is working.
ws1.Rows(j).EntireRow.Copy
Following should be helpful
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, j As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To 10 'change loop as required
If (your_condition) Then
lastRow = lastRow + 1
ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)
End If
Next j
End Sub
Try this:
Code Sample:
Sheets("Sheet1").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Sheet 2").Range("A" & Rows.Count).End(xlUp).Offset(1)
You may use the below code
Sub CopyPaste()
Sheet1.Range("A:A").Copy
Sheet2.Activate
col = 1
Do Until Sheet2.Cells(1, col) = ""
col = col + 1
Loop
Sheet2.Cells(1, col).PasteSpecial xlPasteValues
End Sub
The macro copies and pastes the values of a row X amount of times based on a cell value in M2. It pastes the exact numbers over and over. Is there a way to change it so that numbers will ascend as they are copied down?
E.g. if A2 contains "hello 3", after running the macro A3 will contain "hello 4", A4 will contain "hello 5".
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, j As Long
'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet1")
'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
With wsI
'~~> Get last row of input sheet
lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow_I
'~~> This will loop the number of time required
'~~> i.e the number present in cell M
For j = 1 To Val(Trim(.Range("M" & i).Value))
'~~> This copies
.Rows(i).Copy wsO.Rows(lRow_O)
'~~> Get the next output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
Next j
Next i
End With
End Sub
Example of how input screen and output screen should look:
Example of how output screen should look:
Actually no need for j loop if you use resize method.
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet, lCounter As Long
Dim lRow_I As Long, lRow_O As Long, i As Long
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
With wsI
lCounter = Val(Trim(.Range("M" & i).Value))
lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow_I
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
.Rows(i).Copy wsO.Rows(lRow_O).Resize(lCounter)
Next i
End With
I upgrade my solution to have the "counter" incremented
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, nRowsToPaste As Long
Dim rngToCopy As Range, rngToPaste As Range
'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("SheetI")
Set wsO = ThisWorkbook.Sheets("SheetO") '<=== I made it different that wsI
'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).row + 1
With wsI
'~~> Get last row of input sheet
lRow_I = .Range("A" & .Rows.Count).End(xlUp).row
'~~> Loop through the rows
For i = 2 To lRow_I
nRowsToPaste = val(Trim(.Range("M" & i).Value)) '<== set number of rows to be pasted
Set rngToCopy = .Range(.Cells(i, 1), .Cells(i, wsI.Columns.Count).End(xlToLeft)) '<== set range to be copied
Set rngToPaste = wsO.Rows(lRow_O).Resize(1, rngToCopy.Columns.Count) '<== set 1st row of the range to be pasted
rngToCopy.Copy rngToPaste '<== copy&paste the 1st row in wsO sheet '<== copy and paste the 1st row
Call Prefix(rngToPaste) '<== differentiate each single cell of pasted range by means of adding a different prefix. this will subsequently have autofill method work on cells with originally the same value as well
With rngToPaste
.AutoFill .Resize(nRowsToPaste + 1) ' <== fill all rows exploiting AutoFill method, which will work on every column being their 1st row different from each other
.Resize(nRowsToPaste + 1).Replace What:="%%*%%", Replacement:="", LookAt:=xlPart '<== remove prefix
End With
lRow_O = lRow_O + nRowsToPaste + 1 '<== GET the next output row
Next i
End With
End Sub
Sub Prefix(rng As Range)
Dim j As Long
With rng
For j = 1 To .Columns.Count
.Cells(1, j).Value = "%%" & j & "%%" & .Cells(1, j).Value
Next j
End With
End Sub
where it eliminates the need of the inner j-loop and simply upgrades the lRow_O
I would really appreciate some help to find a correct approach to solve my issue.
I am attempting to loop through all worksheets (except for "Sheet 1" and "Output".
All the above referenced worksheets contain data from cell A2 to last column and last row. I need to copy all the looped ranges (one below the other) in cell C2 in my "Output" worksheet.
Also I have a unique number in A1 in all worksheets (except for "Sheet 1" and "Output" that needs to be copied into B2 in my "Output" worksheet. The trick is (which i am struggling with) the value in A1 needs to be copied down B2 in my "Output" worksheet by the number A2:last row in all my looped worksheets.
Below is my code thus far:
Sub EveryDayImShufflingData()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim Rng As Range
Dim lRow As Long
Dim lCol As Long
Dim maxRow As Integer
Dim x As String
Set PasteSheet = Worksheets("Output")
Application.ScreenUpdating = False
'Loop through worksheets except "Sheet 1" and "Output"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
'Select the Worksheet
ws.Select
'With each worksheet
With ws
'Declare variables lRow and lCol
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'Set range exc. VIN
Set Rng = .Range(.Cells(2, 1), .Cells(lRow, lCol))
'Paste the range into "Output" worksheet
Rng.Copy
PasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
x = .Cells(1, 1).Value
For i = 1 To lRow
PasteSheet.Cells(i, 2).End(xlUp).Offset(1, 0) = x
maxRow = maxRow + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End If
Next ws
End Sub
Any assistance would be kindly appreciated
Try this:
Sub EveryDayImShufflingData()
Dim ws As Worksheet, copyRng As Range, lRow As Long, lCol As Long, PasteSheet As Worksheet
Set PasteSheet = Worksheets("Output")
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set copyRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol))
copyTargetCell = PasteSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1
copyRng.Copy Destination:=PasteSheet.Range("C" & copyTargetCell)
Worksheets("Output").Range("B" & copyTargetCell & ":B" & (copyTargetCell + copyRng.Rows.Count - 1)) = ws.Range("A1")
End If
Next ws
End Sub
How can I modify the following to limit the selection to only start at row 2? Currently it selects every row.
Set myRng = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
To make it work, you will have to ensure that there is data in cell D2. See this example.
Sub Sample()
Dim myRng As Range
Dim ws As Worksheet
Dim Lrow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get last row which has data in Col D
Lrow = .Range("D" & .Rows.Count).End(xlUp).row
If Not Lrow < 2 Then
Set myRng = .Range("D2:D" & Lrow)
MsgBox myRng.Address
Else
MsgBox "There is no data in cell D2"
End If
End With
End Sub