Copy rows starting from certain row till the end using macro - vba

I need to copy values of one excel and create a new one with required format. Say i need to copy columns from B11 to BG11 and rows will be till the end.( i don't know how to find the end of rows). And I have column heading in b7 to bg7. In between there are unwanted rows and i don't need it. So in the new excel i want column headings(which is from b7 to bg7) as first row and the values from b11 to bg11 till the end.
This is my first excel Macro. I don't know how to proceed. So with references from some stackoverflow question and other site, i have tried the below code. but it is not giving the required output.
Sub newFormat()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“B” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Sheets("MySheetName").Range("B7:BG7").Copy
Sheets("MySheetName").Range("B11:BG11").Copy
Workbooks.Open Filename:=”C:\Users\abcd\Documents\Newformat.xlsx”
Worksheets(“Sheet1”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
this may be simple. any help would be appreciated.

Few things...
Do not use Integer for rows. Post xl2007, the number of rows have increased and Integer can't hold that. Use Long
You do not need to select a range to paste on it. You can directly perform the action.
You do not need to use a loop. You can copy ranges in two chunks
Work with objects so Excel doesn't get confused by your objects.
Since Sheet1 is empty, you don't need to find the last row there. Simply start at 1.
To output the data to new workbook, you have to use Workbooks.Add
See this example (Untested)
Sub newFormat()
Dim wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, erow As Long
'~~> Set this to the relevant worksheet
Set wsI = ThisWorkbook.Sheets("HW SI Upload")
'~~> Find the last row in Col B
LastRow = wsI.Range("B" & wsI.Rows.Count).End(xlUp).Row
'~~> Open a new workbook
Set wbO = Workbooks.Add
'~~> Set this to the relevant worksheet
Set wsO = wbO.Sheets(1)
'~~> The first row in Col A for writing
erow = 1
'~~> Copy Header
wsI.Range("B7:BG7").Copy wsO.Range("A" & erow)
'~~> Increment output row by 1
erow = erow + 1
'~~> Copy all rows from 11 to last row
wsI.Range("B11:BG" & LastRow).Copy wsO.Range("A" & erow)
'~~> Clear Clipboard
Application.CutCopyMode = False
'
'~~> Code here to do a Save As
'
End Sub

Different but the same
Rename the sheet
Sub Button1_Click()
Dim wb As Workbook, ws As Worksheet, sh As Worksheet
Dim LstRw As Long, Rng As Range, Hrng As Range
Set sh = Sheets("MySheetName")
With sh
Set Hrng = .Range("B7:BG7")
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Rng = .Range("B11:BG" & LstRw)
End With
Application.ScreenUpdating = 0
Workbooks.Open Filename:="C:\Users\abcd\Documents\Newformat.xlsx"
Set wb = Workbooks("Newformat.xlsx")
Set ws = wb.Sheets(1)
Hrng.Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Rng.Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ws.Name = sh.Name 'renames sheet
wb.Save
wb.Close
End Sub

Related

Excel VBA - Copy mutiple column not in sequence order

I want to copy from one sheet into another. The macro should recognize the worksheet via name:
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Dim NewEnd As Long
Dim NewEnd2 As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("CALC").Select
Worksheets("CALC").Range("B5:J25000").ClearContents
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "15B2" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets("Data")
Set rngToCopy = .Range("F7, H7, N7", .Cells(.rows.Count, "F").End(xlUp))
End With
wb2.Sheets("CALC").Range("B5:D5").Resize(rngToCopy.rows.Count).Value = rngToCopy.Value
End If
This line gives me an error:
Set rngToCopy = .Range("F7, H7, N7", .Cells(.Rows.Count, "F").End(xlUp))
How can I copy mutiple columns in this case?
You can use Union to merge multiple columns to 1 Range.
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row ' get last row with data from column "F"
Set rngToCopy = Application.Union(.Range("F7:F" & LastRow), .Range("H7:H" & LastRow), .Range("N7:N" & LastRow))
rngToCopy.Copy
wb2.Sheets("CALC").Range("B5").PasteSpecial xlPasteValues

Copying the matched row in another sheet

I have two Sheets, sheet1 and sheet 2.
I am looking into column T of sheet1 and pasting the complete row if T contains 1 in sheet 2.
The code, works good, but it paste the result in sheet2 in the same row in sheet1.
This results in blanks, between the rows. Can anyone suggest, what i should Change with my code, so that i get them in sequence without any blank rows.
Also, how can I copy the Header in row 1 from sheet 1 to sheet2?
Sub Test()
For Each Cell In Sheets(1).Range("T:T")
If Cell.Value = "1" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets(1).Select
End If
Next
End Sub
There's no need to use Select and Selection to copy paste, it will only slows down your code's run-time.
Option Explicit
Sub Test()
Dim Cell As Range
Dim NextRow as Long
Application.ScreenUpdating = False
For Each Cell In Sheets(1).Range("T1:T" & Sheets(1).Cells(Sheets(1).Rows.Count, "T").End(xlUp).Row)
If Cell.Value = "1" Then
NextRow = Sheets(2).Cells(Sheets(2).Rows.Count, "T").End(xlUp).Row
Rows(Cell.Row).Copy Destination:=Sheets(2).Range("A" & NextRow + 1)
End If
Next
Application.ScreenUpdating = True
End Sub
Not For Points
Apologies, but I couldn't stop myself from posting an answer. It pains me when I see someone wanting to use an inferior way of doing something :(
I am not in favor of looping. It is very slow as compared to Autofilter.
If you STILL want to use looping then you can make it faster by not copying the rows in the loop but in the end in ONE GO...
Also if you do not like living dangerously then always fully qualify your object else you may end up copying the wrong row.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long, i As Long, r As Long
Dim copyRng As Range
Set wsI = Sheet1: Set wsO = Sheet2
wsO.Cells.Clear
'~~> first available row in sheet2
r = 2
With wsI
lRow = .Range("T" & .Rows.Count).End(xlUp).Row
'~~> Copy Headers
.Rows(1).Copy wsO.Rows(1)
For i = 1 To lRow
If .Range("T" & i).Value = 1 Then
If copyRng Is Nothing Then
Set copyRng = .Rows(i)
Else
Set copyRng = Union(copyRng, .Rows(i))
End If
End If
Next i
End With
If Not copyRng Is Nothing Then copyRng.Copy wsO.Rows(r)
End Sub
Screenshot

VBA - Copy Variable Number of Rows from a Workbook to Another

Our office has recently updated to excel 2013 and a code which worked in the 2010 version is not working. I've searched on several threads here on SO and have yet to find a solution that works for this particular case.
The code identifies and copies a range of cells from an open workbook and logs them into a second workbook, one range of cells at a time. The reason it's set up to copy only 1 row at a time is because the number of rows to be copied varies from time to time. Since the change to 2013, the Selection.PasteSpecial functions have been triggering the debug prompt.
In practice, the worksheet is being used as a routing form. Once it's filled out, we run the code and save all the relevant information in a separate workbook. Since it's a routing form, the number of people on it varies, and we need a row for each person in order to track their 'status'.
The code:
Sub Submit()
'Transfer code
Dim i As Long, r As Range, coltoSearch As String
coltoSearch = "I"
'Change i = # to transfer rows of data. Needs to be the first row which copies over.
'This is to identify how many rows are to be copied over. If statement ends the for loop once an "empty" cell is reached
For i = 50 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
Exit For
End If
'Copies the next row on the loop
Range(Cells(i, 1), Cells(i, 18)).Copy
'open the workbook where row will be copied to
Workbooks.Open FileName:= _
"Workbook2"
'definition for the first empty row in Workbook 2, or the row under the last occupied cell in the Log
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'selects the first cell in the empty row
ActiveSheet.Cells(erow, 1).Select
' Pastes the copied row from Workbook 1 into Workbook 2. First line is highlighted when debugging
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
'moves to the next row
Next i
Any thoughts? I'm open to all options. Thanks for your time.
The Working alternative to select is
ActiveSheet.Cells(erow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
but just for be sure that everything is going fine you have to set the range where i you want to paste everything
dim rngToFill as range
Set rngToFill = ActiveSheet.Cells(erow, 1)
maybe instead of using ActiveSheet you have to define that sheet after opening the wb with
dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open FileName:="Workbook2"
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet
then
set rngToFill = ws.Cells(erow, 1)
then you can paste in that range using .PasteSpecial method, but before doing that, try to be sure that there is no merged cell and that the worksheet we're you are going to paste values is not protected.
rngToFill.PasteSpecial xlPasteValuesAndNumberFormats
Your code:
dim wb as Workbook, ws as worksheet
set wb = Workbooks.Open(FileName:="Workbook2")
set ws = wb.Sheets(nameofthesheet) 'or number of the sheet
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
if erow = 0 then erow = 1
set rngToFill = ws.Cells(erow, 1)
rngToFill.PasteSpecial xlPasteValuesAndNumberFormats
The B plan is to use a for loop iterating throug the cell you want to copy... but it's painfull slowly!
Dim wb As Workbook, newWs As Worksheet, oldWs As Worksheet
Dim z As Integer
Set oldWs = ActiveSheet
Set wb = Workbooks.Open("Workbook2")
Set newWs = wb.Sheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If erow = 0 Then erow = 1
For z = 1 To 18
newWs.Cells(erow, z) = oldWs.Cells(i, z).Value
Next z
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
'moves to the next row
Next i

Fill down the workbook instead of overwriting the first entry over and over again

I am using the following code to copy and paste certain rows into a new workbook:
Sub ReportCreator()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim iCounter As Long
Dim lrow As Long
'~~> Source/Input Workbook
Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Pharmas")
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
lastRow = ThisWorkbook.Worksheets("Pharmas").Cells(Rows.Count, "L").End(xlUp).Row
With wbO
'~~> Set the relevant sheet to where you want to paste
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
For iCounter = 2 To lastRow
If wsI.Cells(iCounter, 4) = "Barr" Then
wsI.Rows(iCounter).Copy
End If
wsO.Range("A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next iCounter
.SaveAs Filename:="C:\Users\rrrrr\Desktop\eeee.xls", FileFormat:=56
End With
End Sub
When the code goes down my list, any row with Barr in column 4 is copied and then pasted onto the new workbook.
The problem I'm encountering is that it's not pasting down the new workbook for each row it finds. Instead on the new workbook, it just overwrites the first row with newer information. When I debug, the code portion that looks for Barr and copies the row is working, but it's not pasting down the workbook, it's just overwriting the first row.
I've tried adding altering the paste code as follows:
wsI.Rows(iCounter).Copy
End If
lrow = Range("A" & .Rows.Count).End(xlUp).Row
wsO.Range("A" & lrow + 1).PasteSpecial Paste:=xlPasteValues,
However, it tells me Object doesn't support this property or method.
I am sure the paste code is incorrect but I'm not sure how to change it so it fills down the workbook instead of overwriting the first entry over and over again with each subsequent find of Barr.
Try this amended code
Sub OhYa()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim iCounter As Long
Dim lrow As Long, rw As Long
'~~> Source/Input Workbook
'Set wbI = ThisWorkbook
'~~> Set the relevant sheet from where you want to copy
Set wsI = Sheets("Pharmas")
'~~> Destination/Output Workbook
Set wbO = Workbooks.Add
lastRow = wsI.Cells(Rows.Count, 4).End(xlUp).Row
With wbO
'~~> Set the relevant sheet to where you want to paste
Set wsO = wbO.Sheets("Sheet1")
'~~>. Save the file
With wsI
For iCounter = 2 To lastRow
If wsI.Cells(iCounter, 4) = "Barr" Then
.Cells(iCounter, 4).EntireRow.Copy
rw = wsO.Cells(wsO.Rows.Count, "A").End(xlUp).Row + 1
wsO.Cells(rw, 1).PasteSpecial Paste:=xlPasteValues
End If
Next iCounter
'.SaveAs Filename:="C:\Users\rrrrr\Desktop\eeee.xls", FileFormat:=56
End With
End With
Application.CutCopyMode = 0
End Sub
In your solution you forgot to reference wsO:
lrow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row
wsO.Range("A" & lrow + 1).PasteSpecial Paste:=xlPasteValues
This solution should work, but should be slow. You can run faster by keeping track of the next row in a variable and icrementing it whenever you paste a row.
If all you want are the values then do not use paste but assign the value to the cell directly.
lrow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row
wsO.rows(lrow + 1).value =wsI.Rows(iCounter).value

VBA macro code for listing names

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