I have a code on the internet that collects data from sheet 3 to the very end one, then combines data to sheet "STOCK DETAILS".
The problem is I just want to paste all the data as value.
I'm new to excel VBA so please help me! Many thanks!
So this is the code:
Sub Combine2()
Dim J As Long, lstrw As Long, lstco As Long, lstrw2 As Long
Dim sTableName As String
'Define Variables
sTableName = "Table1"
Application.ScreenUpdating = False
On Error Resume Next
Sheets("STOCK DETAILS").ListObjects(sTableName).Delete
Sheets(3).Rows(1).Copy Destination:=Sheets("STOCK DETAILS").Range("A4")
For J = 3 To Sheets.Count ' from sheet 2 to last sheet
If WorksheetFunction.CountA(Sheets(J).Cells) > 0 Then
With Sheets(J)
lstrw = .Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
lstco = .Cells.Find(what:="*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
lstrw2 = Sheets("STOCK DETAILS").Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Range(.Cells(2, "A"), .Cells(lstrw, lstco)).Copy Sheets("STOCK DETAILS").Range("A" & lstrw2)(2)
End With
End If
Next
With Sheets("STOCK DETAILS").ListObjects.Add(xlSrcRange, Sheets("STOCK DETAILS").Range("A$4:$L$9999"), , xlYes)
.Name = "Table1"
.TableStyle = "TableStyleLight21"
End With
End Sub
To paste just the values you use
.Range(...).PasteSpecial xlPasteValues
Related
I am trying to add new data to excel sheet via UserForm but it's doesn't write continuously. just replace value of range E2 and its rows.
Note:If data already exist then update its relevant columns or write
new data to next empty row.
my code is below.
Option Explicit
Private Sub cmdAdd_Click()
Dim FindValue As String, Rng As Range
Dim iRow As Long, ws2 As Worksheet
Set ws2 = Worksheets("ITEM NAMES")
iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
FindValue = TextItemName
If Trim(FindValue) <> "" Then
With ws2.Range("E:E")
Set Rng = .Find(What:=FindValue, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Rng.Offset(0, 1) = TextHSNCode.Value
Else
ws2.Cells(iRow, 5).Value = TextItemName.Value
ws2.Cells(iRow, 6).Value = TextHSNCode.Value
End If
End With
End If
End Sub
I have a table with data in a worksheet called 'DL data calculation'. I want to copy the highest row in the table (A21:E21) (after filtering) to (Y3:AC3). The problem I am facing right now is that when I declare the range try to filter, only the A21:E21 row of cells gets copied instead of the highest row. Can someone help me? I entered the script I used underneath.
Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long
Set ws = ActiveSheet
Set mySel = Selection.EntireRow
Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
mySel.SpecialCells(xlCellTypeVisible).Copy
ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll
lRowNew = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow
With myList
.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
End With
Application.CutCopyMode = False
End Sub
I made some changes to create sample data and working code:
Sub CreateSampleData()
Range("A21") = "F1"
Range("B21") = "F2"
Range("C21") = "F3"
Range("D21") = "F4"
Range("E21") = "F5"
Range("A22:E62") = "=INT(RAND()*1000)"
Range("A22:E62").Copy
Range("A22").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$21:$E$62"), , xlYes).Name = "Table1"
End Sub
Sub CopySelectionVisibleRowsEnd()
Dim ws As Worksheet
Dim mySel As Range
Dim lRow As Long
Dim lRowNew As Long
Dim lRowsAdd As Long
Dim myList As ListObject
Dim myListRows As Long
Dim myListCols As Long
Set ws = ActiveSheet 'Sheets("Tabelle1")
Why do you select this row?
You do want to select the first visible row here?
This line just selects the "EntireRow" of the active selection.
Set mySel = Selection.EntireRow
Let's continue with your code:
Set myList = ActiveCell.ListObject
myListRows = myList.Range.Rows.Count
myListCols = myList.Range.Columns.Count
lRow = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlNext, _
LookIn:=xlValues).Row + 1
'Here you copy the row of the active cell (if its visible).
'If you select a cell and make it unvisible with the filter
'you select nothing!
'mySel.SpecialCells(xlCellTypeVisible).Copy
'If you select a cell after the filter this can be copied with
'your code - first 5 cells only:
mySel.Range("A1:E1").SpecialCells(xlCellTypeVisible).Copy
' You want to paste to Cell Y3?
'ws.Cells(lRow, 1).PasteSpecial Paste:=xlPasteAll
ws.Range("Y3").PasteSpecial Paste:=xlPasteAll
'what is it that you want to achieve here?
lRowNew = ws.Cells.Find(What:="*", _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlValues).Row + 1
lRowsAdd = lRowNew - lRow
'I have no idea what you want to achieve here:
'With myList
'.Resize ws.Range(.Range.Resize(myListRows + lRowsAdd, myListCols).Address)
'End With
Application.CutCopyMode = False
End Sub
With the changes above at least the code was working.
Whatever row the cursor is manually placed in -> this row gets copied to the range "Y3:AC3"
With the below code I copy the first visible row (col A to E)
of the list existing on the active sheet and paste it to the
range (Y3:AC3).
Sub CopySelectionVisibleRowsEnd_NEW()
Dim myList As ListObject
Set myList = ActiveSheet.ListObjects(1) 'ActiveSheet.ListObjects("Table1")
Set CopyRange = myList.Range.Offset(1).SpecialCells(xlCellTypeVisible).Range("A1:E1")
CopyRange.Copy
Range("Y3").PasteSpecial Paste:=xlPasteAll
'or PasteValues:
'Range("Y3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
I am trying to accelerate my Excel VB Macro.
I have tried the 5 alternatives below.
But I wonder if I could shorten the execution further.
I found 2 alternatives in User Blogs which I could not get to work.
One alternative is also found in a User Blog but do not understand.
Sub AccelerateMacro()
'
' v1 052817 by eb+mb
' Macro to copy as fast as possible sheet from one workbook into another workbooks
' Declarations for variables are not shown to make code example more legible
' Macro is stored in and run from "DestinationWorkBook.xlsm"
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Alternative = "First"
If Alternative = "First" Then
Workbooks.Open Filename:="SourceWorkBook.xls"
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Windows("SourceWorkBook.xls").Activate
ActiveWorkbook.Close
End If
If Alternative = "Second" Then
Workbooks.Open Filename:="SourceWorkBook.xls", ReadOnly:=True
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Workbooks("SourceWorkBook.xls").Close SaveChanges:=False
End If
If Alternative = "Third" Then
' I could not get this alternative to work
Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet").Copy
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1").PasteSpecial
End If
If Alternative = "Fourth" Then
' I could not get this alternative to work
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1") = Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet")
End If
If Alternative = "Fifth" Then
' I don't understand the code in this alternative
Dim wbIn As Workbook
Dim wbOut As Workbook
Dim rSource As Range
Dim rDest As Range
Set wbOut = Application.Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Application.Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet").UsedRange
wbOut.Sheets("DestinationSheet").Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Instead of using UsedRange, find the actual Last Row and Last Column and use that range. UsedRange may not be the range that you think it is :). You may want to see THIS for an explanation.
See this example (UNTESTED)
Sub Sample()
Dim wbIn As Workbook, wbOut As Workbook
Dim rSource As Range
Dim lRow As Long, LCol As Long
Dim LastCol As String
Set wbOut = Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet")
'~~> Find Last Row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find Last Column
LCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Column Number to Column Name
LastCol = Split(Cells(, LCol).Address, "$")(1)
'~~> This is the range you want
Set rSource = .Range("A1:" & LastCol & lRow)
'~~> Get the values across
wbOut.Sheets("DestinationSheet").Range("A1:" & LastCol & lRow).Value = _
rSource.Value
End With
End Sub
I have an Excel Sheet with about 76.000 rows and 50 Columns. All is just plain text. The saved Excel file is about 16Mb. Is this realistic as the file size seems a bit big too me.
Best
syrvn
I think that 16Mb is could be too much for your file.
Sometimes big excel sheet (expecially if there are pivot tables inside them) have oversize weight if saved with old Excel versions...like Excel 2003, or if they are being saved with different versions multiple times...for Example Excel 2003, then Excel 2010, then again Excel 2003, ...
The best way is to copy all your table into another brand new file and save it, this will have smaller size than the first because you left all unuseful data into the old one.
Another way is to run the Excel Diet macro that you can find here.
Option Explicit
Sub ExcelDiet()
Dim j As Long
Dim k As Long
Dim LastRow As Long
Dim LastCol As Long
Dim ColFormula As Range
Dim RowFormula As Range
Dim ColValue As Range
Dim RowValue As Range
Dim Shp As Shape
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each ws In Worksheets
With ws
'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error GoTo 0
'Determine the last column
If ColFormula Is Nothing Then
LastCol = 0
Else
LastCol = ColFormula.Column
End If
If Not ColValue Is Nothing Then
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
End If
'Determine the last row
If RowFormula Is Nothing Then
LastRow = 0
Else
LastRow = RowFormula.Row
End If
If Not RowValue Is Nothing Then
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
End If
'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
j = 0
k = 0
On Error Resume Next
j = Shp.TopLeftCell.Row
k = Shp.TopLeftCell.Column
On Error GoTo 0
If j > 0 And k > 0 Then
Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
j = j + 1
Loop
If j > LastRow Then
LastRow = j
End If
Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
k = k + 1
Loop
If k > LastCol Then
LastCol = k
End If
End If
Next
.Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
.Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have date mentioned in cell A1, ex - "May".
I am now trying to lock rows 2-last with column Z which mentions date of joining of each employee and compares it to A1.
If month of this cell Z is > A1 then I am trying to lock the row. Not sure what to do.
Below code doesnt help :
Sub Lockrow()
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Integer
Set DestSh = Sheets("Consultant & Teacher")
With DestSh
'finds the last row with data on A column
lastrow = Range("A65536").End(xlUp).Row
'parse all rows
For i = 6 To lastrow
'if your conditions are met
If Month(.Cells(i, 26)) > Month(.Cells(1, 2)) Then
.Range("A" & i).EntireRow.Cells.Locked = True 'lock the row
End If
Next i
End With
End Sub
Is this what you are trying?
Sub Sample()
Dim DestSh As Worksheet
Dim lastrow As Long
'~~> Change this as applicable
Set DestSh = Sheets("Sheet1")
With DestSh
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Columns("A:C").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
MsgBox "Insufficient rows"
Exit Sub
End If
.Unprotect "MyPassword"
.Cells.Locked = False
.Range("A6:C" & lastrow).Locked = True
.Protect "MyPassword"
End With
End Sub