Copy data from one sheet and move to other problems - vba

I'm trying to copy some rows from a sheet and then paste in other sheet that will contain the data. Later on I will erase the data form the original sheet to be fulfill again and repeat process.
My problem is that, it looks like I'm coping as well the empty cells from the original sheet so when paste for any reason excel consider this empty cell as the last one. More than sure I'm doing something wrong, the macro is this:
Sub CopyTable()
'
' CopyTable Macro
'
'
' Variables
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("Form")
Set StartCell = Range("A9")
'Refresh UsedRange
Worksheets("Form").UsedRange
'Find Last Row and Column
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
' Copy range and move to Data sheet
Selection.Copy
Sheets("Data").Select
' Place pointer on cell A1 and search for next empty cell
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
' Once find, go back once to place on last empty and paste data from Form sheet no formating
ActiveCell.Offset(0, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

I assume that the data from the form always has an entry in column A - that there are no entries where A is blank but other cells on the row are not blank:
Sub CopyTable()
Dim sourcesheet As Worksheet
Dim DestSheet As Worksheet
Dim Source As Range
Dim dest As Range
Dim Startcell As Range
Set sourcesheet = ThisWorkbook.Worksheets("Form")
Set Startcell = sourcesheet.Range("A9")
Set Source = sourcesheet.Range(Startcell, Startcell.SpecialCells(xlCellTypeLastCell))
Set DestSheet = ThisWorkbook.Worksheets("Data")
Set dest = DestSheet.Cells(DestSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
'set dest to next blank row
Source.Copy dest
Set dest = DestSheet.Range(dest, dest.SpecialCells(xlCellTypeLastCell))
dest.Sort key1:=dest.Cells(1, 1)
'sort to shift blanks to bottom
End Sub

finally surfing in stackoverflow I found a pice of code that do exactly want I need, so final macro looks like this:
Sub CopyTable()
Dim lastVal As Range, sht As Worksheet
Set sht = Sheets("Form")
Set lastVal = sht.Columns(2).Find("*", sht.Cells(1, 2), xlValues, _
xlPart, xlByColumns, xlPrevious)
Debug.Print lastVal.Address
sht.Range("A9", lastVal).Resize(, 26).Select 'select B:Ag
Selection.Copy
Sheets("Data").Select
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

Related

Excel VBA: Subscript out of range code fix

I keep getting a subscript out of range error in the line
Sheets("Dump").Select
How can I adjust my code to remove the error? And is there a way to adjust this to remove the .Select
Sub UploadData()
'open the source workbook and select the source
Dim wb As Workbook
Workbooks.Open Filename:=Sheets("Instructions").Range("$B$4").value
Set wb = ActiveWorkbook
Sheets("Invoice Totals").Select
'copy the source range
Sheets("Invoice Totals").Range("A:R").Select
Selection.Copy
'select current workbook and paste the values
ThisWorkbook.Activate
Sheets("Dump").Select
Sheets("Dump").Range("A2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' copy the source range
Sheets("Lease & RPM Charges").Range("A:AH").Select
Selection.Copy
'select current workbook and paste the values
ThisWorkbook.Activate
Sheets("Dump").Select
Sheets("Dump").Range("T2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'copy the source range
Sheets("MMS_Service_And_Repairs").Range("A:R").Select
Selection.Copy
'select current workbook and paste the values
ThisWorkbook.Activate
Sheets("Dump").Select
Sheets("Dump").Range("BC2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'close the source workbook
wb.Close
End Sub
Edit(Fixed issues) Try this...(Tested on mock data).
Sub UploadData()
Dim wb As Workbook
Dim lRow As Long, lRow2 As Long, lRow3 As Long 'Set lastrow for each source worksheet
Dim rng As Range, rng2 As Range, rng3 As Range 'Set range for each source worksheet
'open the source workbook using the filename in cell B4(I'm making an assumption that the
'source workbook is located in the same folder as the Thisworkbook
Set wb = Workbooks.Open(Filename:=Sheets("Instructions").Range("$B$4").Value)
With wb
With .Sheets("Invoice Totals") 'Copy the range on this ws and paste to "Dump" in dest ws
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range("A1:R" & lRow)
rng.Copy Destination:=ThisWorkbook.Sheets("Dump").Range("A2")
End With
With .Sheets("Lease & RPM Charges") 'Copy the range on this ws and paste to "Dump" in dest ws
lRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng2 = .Range("A1:AH" & lRow2)
rng2.Copy Destination:=ThisWorkbook.Sheets("Dump").Range("T2")
End With
With .Sheets("Invoice Totals") 'Copy the range on this ws and paste to "Dump" in dest ws
lRow3 = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng3 = .Range("A1:R" & lRow3)
rng3.Copy Destination:=ThisWorkbook.Sheets("Dump").Range("BC2")
End With
With ThisWorkbook.Sheets("Dump").UsedRange
.Value = .Value 'Sets all the data in the usedrange to values only
End With
End With
wb.Close 'close the source workbook
End Sub

Copy variable range of values not formulas

I'm trying to copy a variable range from one book (Book1) to the end of a variable range of the another book (book2). I'm interested only in values of the variable range in the book 1 and this is the problem. So I need to find the last row of values (not formulas). On this forum I found several options but none of them works in my case. Here is what I got (Please see the second part of the code "Copy Detail USHB"-'Select cells to copy):
''''''Copy Detail by Vendor''''''
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Detail by Vendor")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
Workbooks.Open Filename:= _
"Book2.xlsm"
'Set selectedworkbook
Set wb2 = ActiveWorkbook
'Select cells to copy
Sheets("By Vendor").Select
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail by Vendor").Select
'Paste starting at the last empty row
wb.Worksheets("Detail by Vendor").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
'''''Copy Detail USHB'''''
'Last cell in column
Set WS = Worksheets("Detail USHB")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
'Activate the target workbook
wb2.Activate
'Select cells to copy
Sheets("Detail USHB").Select
Dim jLastRow As Long
jLastRow = Columns("B").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range(Selection, ActiveCell.SpecialCells(xlLastRow).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail USHB").Select
'Paste starting at the last empty row
wb.Worksheets("Detail USHB").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Following your comments, I believe you are trying to do the following:
'...
'''''Copy Detail USHB'''''
Dim D As Range
Dim S As Range
With wb2.Worksheets("Detail USHB")
'Locate the last non-blank value in source range
LastRow = .Range("B:B").Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
'Set range
Set S = .Range("B2:B" & LastRow)
End With
With wb.Worksheets("Detail USHB")
'Find last used cell in destination range
Set D = .Range("B" & .Rows.Count).End(xlUp)
'Offset to next row, and resize appropriately
Set D = D.Offset(1, 0).Resize(LastRow - 1, 1)
End With
'Copy values
D.Value = S.Value
End Sub

Copying formula and Format from row above Macro

I have a spreadsheet for entering a new set of data on a new row each day each day, the row contains formulas and formatting. I want to be able to click a button and it adds a row under the last row with entered data and copy the formulas and formatting only, ready for new data to be entered.
Below is my code:
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
Set ws = ThisWorkbook.Sheets("Summary")
With ws
varUserInput = .Range("D" & .Rows.Count).End(xlUp).Row
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub
The issue is that it will only copy the formula from the same hidden row each time.
Is this what you are trying (UNTESTED)?
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
varUserInput = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If varUserInput = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Change as applicable
With ws
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub

VBA code to select specific cell and paste down accordingly

I want to select specific cells from all the worksheets present in my Excel workbook and then paste in a master sheet. Problem is I am not getting that from the code created, I get an error but if I leave it as it is right now (shown below) I get it for a specific cell and then I have to go into the code to change the cell and where I want it outputted to. I apologize in advance for my naivety.
As it is right now
Sub CopyIt()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Masters" Then
ws.Range("B18").Copy Sheets("Masters").Cells(Rows.Count, "Q").End(xlUp).Offset(1)
End If
Next
Application.ScreenUpdating = True
End Sub
I want this cell range "B2-B18" to be copied to "A:Q" and in the master sheet. So values in B2 go to A column and so on and so and then at the end B18 goes to Q.
What did I not do for the code to do what it should?
Hey I just tested this and it should do the trick for you
Sub CopyIt()
Dim pasteRow As Integer
Dim ws As Worksheet
Application.ScreenUpdating = False
pasteRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Masters" Then
ws.Range("B2", "B18").Copy
Sheets("Masters").Range("A" & pasteRow).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
pasteRow = pasteRow + 1
End If
Next
Application.ScreenUpdating = True
End Sub
This will advance a row for each worksheet so you can add as many worksheets as you like. Note that this really isn't the most universal code, you would need to change the ws.Range("B2", "B18").copy to something that would select say, all ranges in a column or you will have to manually expand the range each time you want to change it.
Try:
ws.Range("B1:B18").Copy
Sheets("Masters").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
That should copy B1:B18, transpose it from columns to rows and paste it in the last row in Column A of your Masters sheet.
enable developer toolbar
select record a macro
select b2:b18 in a one sheet select another sheet and right click paste special all and also select transpose
stop recording macro
now edit the macro to suit your requirements
a sample macro autogenerated code as follows
Sub Macro1()
'
' Macro1 Macro
'
'
Range("B2:B18").Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
This should do the required...
(This will copy paste values from B2:B18 cells in each sheet to different rows in the Sheet "Masters")
Sub Macro1()
Dim ws As Worksheet
Dim row_count As Integer
row_count = 1
For Each ws In ActiveWorkbook.Worksheets
MsgBox ws.name
If ws.name <> "Masters" Then
ws.Activate
Range("B2:B18").Select
Selection.Copy
Sheets("Masters").Activate
Range("A" & row_count).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
row_count = row_count + 1
End If
Next
End Sub

Simples repeat macro in Excel

I've googled this but couldn't find a clear answer.
I have a workbook that contains lots of sheets, each sheet contains purchase order info.
I want to copy the same cell range from each sheet and compile a long list of all of those ranges.
my codes is currently;
Sub WorksheetLoop()
Sheets("5040001253").Select
Range("A4:O23").Select
Selection.Copy
Sheets("PO_Combi").Select
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Range("A" & lastRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
My question is: is there a simple command that allows to replace the sheet named 5040001253 with that will make this macro repeat on all sheets? If not, could someone tell me what to do to make it so?
Next code copies Range("A4:O23") from each sheet (except PO_Combi) to column A of sheet PO_Combi:
Sub WorksheetLoop()
Dim sh As Worksheet
Dim shCombi As Worksheet
Dim lastrow As Long
Set shCombi = ThisWorkbook.Worksheets("PO_Combi")
For Each sh In ThisWorkbook.Worksheets
With shCombi
If sh.Name <> .Name Then
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
sh.Range("A4:O23").Copy
.Range("A" & lastrow + 1).PasteSpecial xlPasteValues
End If
End With
Next
Application.CutCopyMode = False
End Sub