How to copy rows of from one sheet to another sheet using vbscript - vbscript

Suppose I have Sheet(1) in an excel. Now i do also have 2500 rows which has data for the columns from A to BO.Now I want the data to copy from these sheet to another sheet of the same Excel file for 2500 rows but not the whole the columns,rather i need only columns from A to AA data to copy to the new sheet.
So how to frame it using VBscript?
Please help me.
How to copy rows of from one sheet to another sheet using vbscript

To copy data from one sheet to another you can use the Copy en PasteSpecial commands. To do this with a .vbs script do the following:
' Create Excel object
Set objExcel = CreateObject("Excel.Application")
' Open the workbook
Set objWorkbook = objExcel.Workbooks.Open _
("C:\myworkbook.xlsx")
' Set to True or False, whatever you like
objExcel.Visible = True
' Select the range on Sheet1 you want to copy
objWorkbook.Worksheets("Sheet1").Range("A1:AA25").Copy
' Paste it on Sheet2, starting at A1
objWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial
' Activate Sheet2 so you can see it actually pasted the data
objWorkbook.Worksheets("Sheet2").Activate
If you want to do this in Excel with a VBS macro you can also call the copy and paste methods. Only your workbook object will be something like ActiveWorkbook

This code is Working fine. Just Copy and paste it.
Dim CopyFrom As Object
Dim CopyTo As Object
Dim CopyThis As Object
Dim xl As Object
xl = CreateObject("Excel.Application")
xl.Visible = False
CopyFrom = xl.Workbooks.Open("E:\EXCEL\From.xls")
CopyTo = xl.Workbooks.Open("E:\EXCEL\To.xls")
For i = 0 To 1
''To use a password: Workbooks.Open Filename:="Filename", Password:="Password"
If i = 0 Then
CopyThis = CopyFrom.Sheets(1)
CopyThis.Copy(After:=CopyTo.Sheets(CopyTo.Sheets.Count))
CopyTo.Sheets(3).Name = "Sheet3"
Else
CopyThis = CopyFrom.Sheets(2)
CopyThis.Copy(After:=CopyTo.Sheets(CopyTo.Sheets.Count))
CopyTo.Sheets(4).Name = "Sheet4"
End If
Next
CopyTo.Sheets(1).Activate()
CopyTo.Save()
'CopyTo.SaveAs("E:\EXCEL\Check.xls")
xl.Quit()

Sub buildMissingSheet(strMissingSheet) 'Just passing the missing sheet name in
' Master Sheet code
' Working on creating the "Master Sheet" at this time...May need to seperate the the code a little.
Dim GetRows1 As Worksheet
Dim GetRows2 As Worksheet
Dim PutRows As Worksheet
Dim sglRowNum As Single, i%
If strMissingSheet = strMASTERSHEET Then ' Create the strMASTERSHEET
Set GetRows1 = Sheets(strRAWDATA) ' These two sheets could be missing but will code around that later.
Set GetRows2 = Sheets(strDATAWITH) ' The two sheets I am getting rows from
' Just creating a new worksheet here assuming it is missing
Worksheets.Add(After:=Worksheets(5)).Name = strMissingSheet
Set PutRows = Sheets(strMissingSheet) ' Missing sheet must be created before declaring.
PutRows.Select 'Select the sheet being built.
With Cells(1, 1)
.Value = strRAWDATA 'Not copying rows here but left it in this example anyway
.AddComment
.Comment.Visible = False
.Select
.Comment.Text Text:= _
Chr(10) & "Name of sheet including header and the last 32 entries at the time this sheet was updated."
End With
'Here is where we copy the whole row from one sheet to the other.
GetRows1.Rows(1).Copy PutRows.Rows(2) 'Copy header row from existing sheet to "Master Sheet" for instance.
GetRows1.Select
sglRowNum = ReturnLastRow(ActiveSheet.Cells) 'return last row with data on active sheet
' I wanted the last few rows of data "32 rows" so found the end of the sheet this code can be found on the internet in several places including this site.
'Now the code you may have been looking for move 32 row of data from one sheet to another.
For i = 1 To 32 'Start at row 3 on the Put sheet after sheet name and header.
GetRows1.Rows(sglRowNum - (32 - i)).Copy PutRows.Rows(i + 2)
Next i
end sub

Related

How to ensure every related data is being referenced, newly pasted result having related data for referenced also, how to let VBA do this?

i wanna to look for sheet 2 column H value in sheet 1 column A and then copy and paste matching data from sheet 1 to sheet 2 column A last empty row.. had written below VBA but somehow not all matching line can be copied and paste from sheet 1.. and for those just newly copy and paste from sheet 1 data, is carrying value for column H, again i need to look for this column H new data from sheet 1 and then copy and paste to sheet 2 (repeat same action)...how to write VBA for doing this continuos action then VBA stop when all column H data is already referenced and having copy and paste line from sheet1?
Had tried to write below VBA according to i wanna to achieve result.
Sub MatchData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long, lastRowA As Long
Dim i As Long, j As Long
Dim matchFound As Boolean
'Set worksheet variables
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'Get last row for both sheets
lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, "H").End(xlUp).Row
'Get last row in Sheet2 column A
lastRowA = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'Loop through Sheet2 column H data and match with Sheet1 column A
For i = 1 To lastRow2
matchFound = False 'Reset matchFound flag for each row
If Not IsEmpty(ws2.Cells(i, 8)) Then 'Check if Sheet2 column H cell is not empty
For j = 1 To lastRow1
If ws2.Cells(i, 8) = ws1.Cells(j, 1) And ws2.Cells(i, 9) = ws1.Cells(j, 2) Then 'Match found
matchFound = True
'Check if matching row is a duplicate
If WorksheetFunction.CountIf(ws2.Range("A1:B" & lastRowA), ws1.Cells(j, 1).Value & ws1.Cells(j, 2).Value & ws2.Range("A" & i).Value & ws2.Range("B" & i).Value) = 0 Then
'Copy matching row to Sheet2 column A last empty row
ws1.Rows(j).EntireRow.Copy ws2.Cells(lastRowA + 1, "A")
lastRowA = lastRowA + 1 'Update last empty row in Sheet2 column A
End If
End If
Next j
End If
Next i
MsgBox "Matching and copying rows completed!"
End Sub

Arrays to filter, copy and past - quick macro method

I want to make an Excel workbook that I have much quicker.
I have a big product database with the product names, quantities, delivery number and delivery date (ProductDB). I put in another sheet the products that I have sold (product names and quantity sold) and want to filter and copy those that are corresponding from the database so I can calculate in the second step the remaining quantity and past the remaining quantity to the database.
Everything is working well and the calculation is good. The only thing is, the Advancedfilter xlfiltercopy option is too slow if I have to input 5000 lines of product names.
I have heard that arrays are much faster. How could I do that? The current way I do it is like this:
Sub UseFilter()
Application.ScreenUpdating = False
Sheet1.Range("G1:Z100000").Cells.Delete
Dim lastrow As Long, c As Range
Dim myrange As Range
Dim rngCell As Range
Dim wksSheet As Worksheet
Dim wksSheetDB As Worksheet
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
Sheet1.Columns("G").NumberFormat = "0"
Filter product codes from the database according to sold product codes:
Set myrange = Range("A1:A" & lastrow)
For Each c In myrange
If Len(c.Value) <> 0 Then
ThisWorkbook.Worksheets(Worksheets.Count).Columns("A:D").AdvancedFilter xlFilterCopy, _
Sheet1.Range("A1:A" & lastrow), Sheet1.Range("G1"), False
End If
Next
Sort the filtered list first by product code, then by the delivery number:
Dim lngRowMax As Long
Dim wsf As WorksheetFunction
With Sheet1
lastrow = Cells(Rows.Count, 8).End(xlUp).Row
Range("G1:J" & lastrow).Sort Key1:=Range("G1:G" & lastrow), _
Order1:=xlAscending, Key2:=Range("I1:I" & lastrow), _
Order2:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
Set wsf = Application.WorksheetFunction
lngRowMax = .UsedRange.Rows.Count
End With
I'm only interested in filtering and copying of the corresponding product information (name (A), quantity (B), delivery nr (C) and date (D)). Does anyone know how I can do that?
Thank you very much in advance. I'm really looking forward for a solution that improves the pace of the file. Currently it is unbelievably slow.
i had the same problem with advanced filter being so slow. you might want to consider using dictionary. for my 2 spreadsheets i wanted to compare i made 2 dictionaries and compared the values and it was so amazingly fast. dictionaries are really easy and a simple google search you can find a ton of tutorials and examples. good luck.
There is a possible solution with dictionaries, but I have only one small issue. I will explain after the code:
'Count num rows in the database
NumRowsDB = ThisWorkbook.Worksheets(Worksheets.Count).Range("A2", Range("A2").End(xlDown)).Rows.Count
' --------------------- SAVE DATABASE DATA -----------------------
'Dictionary for all DB data
Set dbDict = CreateObject("Scripting.Dictionary")
Set dbRange = Range("A2:A" & (NumRowsDB + 1))
For Each SKU In dbRange
If Len(SKU.Value) <> 0 Then
' check if the SKU allready exists, if not create a new array list for that dictionary entry
' a list is necessary because there can be multiple entries in the db range with the same SKU
If Not dbDict.Exists(CStr(SKU.Value)) Then
Set prodList = CreateObject("System.Collections.ArrayList")
dbDict.Add CStr(SKU.Value), prodList
End If
' for this specific product code, save the range where the product information is saved in the dictionary
rangeStr = "A" & SKU.Row & ":D" & SKU.Row
dbDict(CStr(SKU.Value)).Add (rangeStr)
End If
Next
' ----------- READ SALE/Reverse/Consumption INFO ------------------
NumRowsSale = Range("A2", Range("A2").End(xlDown)).Rows.Count
Set saleRange = Range("A2:A" & (NumRowsSale + 1))
Dim unionRange As Range
For Each sale In saleRange
' check if the SKU for the sale exists in db
If Len(sale.Value) <> 0 And dbDict.Exists(CStr(sale.Value)) Then
For Each dbRange In dbDict(CStr(sale.Value))
If unionRange Is Nothing Then
Set unionRange = Range(dbRange)
Else
Set unionRange = Union(unionRange, Range(dbRange))
End If
Next
End If
Next
unionRange.Copy Destination:=Range("G2") 'copy all received ranges to G2
Set dbDict = Nothing
The line "NumRowsDB = ThisWorkbook.Worksheets(Worksheets.Count).Range("A2", Range("A2").End(xlDown)).Rows.Count" is not working. I have to refer to another sheet (the last sheet which is the current database) to get the data. What is the problem that I cannot refer to another sheet in the same workbook?
Thank you for your suggestions.

Excel VBA - Stops Selecting Visible Rows on Filter after many interations

My code takes a file name from TextBox1, opens that file and indexes through all the unique values in column B. It then takes a second file, file name in TextBox2, and filters it based on the current index from the first file. It then takes the filtered results and copies them to a sheet in the new workbook. A new sheet is then generated in the new workbook to paste the next filtered result.
My issue is that I have many rows of data and for some reason the filtered data is not be selected after many iterations. My program selects all filtered data when it starts, but at some point it just begins selecting the headers instead of all the visible cells. Let me know if I am missing something or if there is a quick workaround. Thank you.
Sub NewFileGenerate()
Dim I As Integer
Dim N As Integer
Dim X As Integer
Dim IndexedCell As String
X = 1
Windows(TextBox1.Value).Activate
'Need to count only populated cells
I = Sheets(1).Columns(2).Cells.SpecialCells(xlCellTypeConstants).Count
Set Newbook = Workbooks.Add
For N = 2 To I - 1
Application.CutCopyMode = True
Windows(TextBox1.Value).Activate
IndexedCell = Cells(N, 2).Value
Windows(TextBox2.Value).Activate
With Sheets(1)
With .Range("A1", "Z" & I - 1)
.AutoFilter Field:=5, Criteria1:=IndexedContract
.SpecialCells(xlCellTypeVisible).Copy
End With
End With
Newbook.Activate
ActiveSheet.Paste Destination:=Sheets(X).Range("A1:Z1")
Cells.Select
Selection.Font.Size = 10
Cells.EntireColumn.AutoFit
Cells.Select
X = X + 1
If X > 3 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Sheet" & X
End If
Application.CutCopyMode = False
Next N
End Sub
I'm guessing that your source worksheet (textbox2.value) has more rows than your index worksheet (textbox1.value). You set I equal to the number of rows in your index worksheet, then you tell the autofilter to only use that number of rows. You need to change the line "With .Range("A1", "Z" & I - 1)" so it picks up all of the rows in your source worksheet.

Select end row of table, copy and paste in another workbook

I have 2 workbooks.
Source Workbook
- Select a cell in column B, last row of a table. e.g. B29 (But this would change as the table grows)
2nd Workbook
- Paste that cell into G14 of the 2nd workbook (This doesn't change)
Source Workbook
- Select a cell in column D, same row - last row of table. e.g.. D29
2nd Workbook
- Paste that cell into D8 (This doesn't change)
This same process repeats 4 more times (Columns E-H) and all the pasting is done into C3, F14, I14 and E14 respectively.
The following code will do what you need. Just make the changes mentioned in the comments.
Sub Copy2Workbook() 'You need to place this in your source workbook!
Dim wbT As Workbook ' target workbook
Set wbT = Workbooks("United")
Dim shtT As Worksheet 'target worksheet
Set shtT = wbT.Worksheets("Name of target sheet") ' change name to fit your case
Dim shtS As Worksheet 'source worksheet
Set shtS = ThisWorkbook.Worksheets("Name of source sheet") ' change name to fit your case
Dim lastRow As Long
'*****************************************
lastRow = shtS.Cells(Rows.Count, "B").End(xlUp).Row
shtT.Range("G14").Value = shtS.Range("B" & lastRow).Value
'repeat the two lines of above while changing the references to your needs
End Sub

How to add data to a specific column in an existing excel file using VBScript

I'm currently doing automation testing and need to write a dynamic value to an existing excel document in a specific column, this is what I have so far. Forgive I'm a novice
Sub WriteTRNtoExcelDoc
Dim fileName, sheetName
fname = "<Path_To_The_File>"
sheetName = "Sheet1"
Set app = Sys.OleObject("Excel.Application")
Set book = app.Workbooks.Open(fname)
Set sheet = book.Sheets(sheetName)
' What do I do next to add a value to a specific column or cell in this
' spreadsheet?
End Sub
Thanks in advance!
You create an Excel instance in a VBScript with
CreateObject("Excel.Application")
An already running Excel instance can be grabbed with
GetObject(, "Excel.Application")
In a worksheet you can access cells by using the Cells property:
Set app = CreateObject("Excel.Application")
app.Visible = True
Set book = app.Workbooks.Open(fname)
Set sheet = book.Sheets(sheetName)
sheet.Cells(2,3).Value = "foo"
Edit: If you need to find the first empty cell in a given column, you can use something like this:
row = 1
Do Until IsEmpty(sheets.Cells(row, 3).Value)
row = row + 1
Loop
sheet.Cells(row, 3).Value = RemPropValue

Resources