Excel vba count last row source file - vba

I am relatively new to VBA.
I have a target workbook where the first step is somebody has to write something. If not an error message pops up.
After they filled in their data the code will ask them to open the source workbook(they downloaded the file before). From the source workbook certain columns are read. This all works fine in the code. The problem I have is to get what they filled in the target workbook to be copied down in column (A4:A(last row in source workbook). So the length until where their manually entered data has to be copied down has to be equal to the length of data in the source workbook.
Sub get_rate_codes()
Dim CheckCell As Range
Dim wb_source As Workbook
Dim wb_target As Workbook
Dim strPathName As String
Dim lastRow As Long
For Each CheckCell In Sheets("rate_codes").Range("F3").Cells
If Len(Trim(CheckCell.Value)) = 0 Then
CheckCell.Select
MsgBox "Cell " & CheckCell.Address(0, 0) & " is empty. Please enter SITA."
Exit Sub
End If
Next CheckCell
'start to open file
Application.ScreenUpdating = False
'start is the starting cell while lastRow measures the last data row in the external file
Start = 4
'continue to copy data from the rate codes report
Set wb_target = ActiveWorkbook
With wb_target.Sheets("rate_codes")
lastRow = wb_source.UsedRange.SpecialCells(xlCellTypeLastCell).Row
strPathName = Application.GetOpenFilename()
If strPathName = "False" Then
Exit Sub
End If
Set wb_source = Workbooks.Open(strPathName, 0)
.Range("B" & Start & ":B1000").Value = wb_source.Sheets(1).Range("E2:E1000").Value
.Range("C" & Start & ":C1000").Value = wb_source.Sheets(1).Range("H2:H1000").Value
.Range("D" & Start & ":D1000").Value = wb_source.Sheets(1).Range("G2:G1000").Value
.Range("E" & Start & ":E1000").Value = wb_source.Sheets(1).Range("K2:K1000").Value
.Range("A" & Start & ":A" & lastRow).Value = wb_target.Sheets(2).Range("F2").Value '
wb_source.Close (False)
End With
'close file without saving
Application.ScreenUpdating = True
End Sub

To find the last row you can do this.
Dim lastRow As Long
lastRow = wb_source.Cells(wb_source.Rows.count, "A").End(xlUp).Row
Then you can write to the next line.
.Range("A" & lastRow + 1).Value =

Related

Vba search and paste solution

i would like to come up with vba sub that searching value from one specified cell (job) across all sheets and then pastes rows but only with selected columns. If value not found any error message instead paste value.
I know it's bigger project but I'm fresh so try to my best.
As far i have solution for whole rows:
Sub TEST()
Dim tws As String
Dim l_row As String
Dim l_rowR As String
Dim job As String
Dim i As Integer
Set tws = ThisWorkbook.Sheets("Data")
tws.Range("A20") = "STATS:"
job = tws.Range("B5")
lastRow = Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Worksheets("Sheet1").Range("E" & i).Value = job And _
Worksheets("Sheet1").Range("D" & i).Value = "x2" Then
Worksheets("Sheet1").Rows(i).Copy
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
tws.Range("A" & lastRowRpt + 1).Select
tws.Paste
End If
Next i
End Sub

vba copy corresponding values from another workbook?

I have two workbooks:
Planner
Column K Column AG
123 £100
246 £20
555 £80
Master
Column D Column R
123 £100
246 £20
555 £80
I am trying to copy the values from Planner, Column AG into Column R (Master) where my item numbers in Column D (Master) match with column K (Planner).
My code below produces no error and it is not producing any results - despite their being several matches.
Please can someone show me where i am going wrong?
For the avoidance of doubt, my workbook is definitely opening ok so is finding the file.
Code:
Sub PlannerOpen()
'Set Variables
Dim wb2 As Workbook
Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim app As New Excel.Application
'Find Planner
If Len(FindDepotMemo) Then
'If Found Then Set Planner Reference.
app.Visible = False 'Visible is False by default, so this isn't necessary
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wb2 = Workbooks.Open(FindDepotMemo, ReadOnly:=True, UpdateLinks:=False)
'If We have our planner lets continue...
'With my workbook
With wb2.Worksheets(1)
lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
'Lets begin our data merge
j = 2
For i = 2 To lastRow
'If data meets criteria
'Check Planner For Turnover
If ThisWorkbook.Worksheets("Data").Range("D" & j).Value = .Range("K" & i).Value Then ' check if Item number matches
ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & i).Value
j = j + 1
End If
'Continue until all results found
Next i
End With
'All Done, Let's tidy up
'Close Workbooks
'wb2.Close SaveChanges:=False
'app.Quit
'Set app = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
Function FindDepotMemo() As String
Dim Path As String
Dim FindFirstFile As String
Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
FindFirstFile = Dir$(Path & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function
Instead of having 2 For loops, just use the Application.Match to find matches between values in your 2 workbooks.
Use this code section below to replace with yours:
With wb2.Worksheets(1)
Dim MatchRow As Variant '<-- define variable to get the row number if Match is successful
lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
'Lets begin our data merge
For i = 2 To lastRow
' If data meets criteria
' Check Planner For Turnover
' Use Application.Match to find matching results between workbooks
If Not IsError(Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0)) Then ' check if Match is successful
MatchRow = Application.Match(ThisWorkbook.Worksheets("Data").Range("D" & i).Value, .Range("K2:K" & lastorw), 0) ' <-- get the row number where the match was found
ThisWorkbook.Worksheets("Data").Range("R" & j).Value = .Range("AG" & MatchRow).Value
End If
'Continue until all results found
Next i
End With
you could refactor your code as follows:
Option Explicit
Sub PlannerOpen()
Dim dataRng As Range, cell As Range
Dim depotMemo As String
Dim iRow As Variant
If FindDepotMemo(depotMemo) Then '<--| if successfully found the wanted file
With ThisWorkbook.Worksheets("Data1") '<--| reference your "Master" workbook relevant worksheet
Set dataRng = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp)) '<--| set its item numbers range
End With
With Workbooks.Open(depotMemo, ReadOnly:=True, UpdateLinks:=False).Worksheets(1) '<--| open depotMemo workbook and reference its first worksheet
For Each cell In .Range("K2", .Cells(.Rows.Count, "K").End(xlUp)) '<--| loop through referenced worksheet column "K" cells from row 2 down to last not empty one
iRow = Application.Match(cell.Value, dataRng, 0) '<--| try finding current depotMemo item number in Master item numbers range
If Not IsError(iRow) Then dataRng(iRow, 1).Offset(, 14).Value = cell.Offset(, 22) '<--| if found then grab depotMemo current item amount and place it in corresponding "master" data sheet column R
Next
.Parent.Close False
End With
End If
End Sub
Function FindDepotMemo(depotMemo As String) As Boolean
Dim Path As String
Dim FindFirstFile As String
Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "8." & " " & Year(Date) & "\"
FindFirstFile = Dir$(Path & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = True
depotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function

VBA Script Code for reading a xls and manipulating cells

I have an excel sheet with just one worksheet. The first row of this excel sheet has the Title for the columns.
The worksheet has data in below columns and n number of rows:
Columns: A | B | C | D | E | F | G | H
First I am creating a copy of the file and renaming it - This WORKS!
'Copy and rename the file
Dim sourceFile As String, destFile As String
sourcePath = Range("D6")
destFile = Split(sourcePath, ".")(0) + "_Formated.xls"
FileCopy sourcePath, destFile
I want to read this destFile excel sheet via VBA code. I will doing some cell manipulation so please give me a working code to understand how that whole worksheet is read and how I can access a particular row while in a for loop.
I also want to know the code to add new column title and values to this destFile excel sheet via VBA code.
Whats the code for just clearing the cell value via VBA code and not delete the cell.
I want to read this destFile excel sheet via VBA code. I will doing some cell manipulation so please give me a working code to understand how that whole worksheet is read and how I can access a particular row while in a for loop.
dim sh as Worksheet
set sh = Workbooks.Open(destFile).Worksheets(1)
I also want to know the code to add new column title and values to this destFile excel sheet via VBA code.
sh.rows(1).Insert Shift := xlDown
ThisWorkbook.Worksheets(1).Rows(1).Copy sh.Rows(1)
Whats the code for just clearing the cell value via VBA code and not delete the cell.
sh.Range("A1").Value = ""
I managed to get this done with the below code.
This is the worst way to code it and does not look anything sophisticated but it gets the job done.
Thanks!
Sub Format()
'Copy and rename the file
Dim SourceFile As String, DestFile As String
SourceFile = Range("D6")
SourceString = Range("D3")
TestSuiteName = Range("D2") & "\"
DestFile = Split(SourceFile, ".")(0) + "_Formated.xls"
On Error GoTo ErrorHandler:
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FileExists(DestFile) Then
FileCopy SourceFile, DestFile
End If
'Read DestFile worksheet content
Dim wks As Worksheet
Set wks = Workbooks.Open(DestFile).Worksheets(1)
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 6).Value = "Step 1" Then
Cells(i, 7) = "Other_Migration_Fields" & Cells(i, 7) & vbLf & vbLf & "QC Path:" & Cells(i, 8)
Cells(i, 8) = Replace(Cells(i, 8), SourceString, TestSuiteName)
Else
Cells(i, 1) = ""
Cells(i, 2) = ""
Cells(i, 7) = ""
Cells(i, 8) = ""
End If
Next i
ErrorHandler:
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
If Err.Number <> 0 Then
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
Else
MsgBox "Success!"
End If
Exit Sub
End Sub

I need to create new sheets based on unique names found in column A. Current Code generates excess data in certain sheets

I have the following code so far based on questions asked by other people.
I have a set of names listed in column A, and 216 columns and 9725 rows of data.
Currently using the following code I get the new sheets created except along with the unique names and its relevant data I get many cells filled with "#N/A".
In certain cases, the name Bob for example will be populated in a new sheet called Bob but the first column will have Bob and all relevant data and once all Bobs rows are shown it is follower with many rows with #N/A and all columns with #N/A.
In other cases the sheet will be created for Charles and all of Charles data will be listed, then many rows of #N/A and then all of the master-data including other peoples names which I need to avoid.
I want each individual sheet to only have the info based on the name of the person on that sheet. All of the data gets copied as I verified the number of accurate cells that get populated yet I get these #N/A cells and duplicated extra data and I'm not sure how to stop it from being populated? Any help in cleaning the code would be appreciated!!
Code:
Sub CopyDataFromReportToIndividualSheets()
Dim ws As Worksheet
Set ws = Sheets("FormulaMSheet2")
Dim LastRow As Long
Dim MyRange As Range
Worksheets("FormulaMSheet2").Activate
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
' SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1")
', Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim allAgentNameCells As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set allAgentNameCells = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In allAgentNameCells
If cell.Value <> " " And cell.Value <> "" Then
' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.
' Current Row's Series not SPACE
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
End If
Next
'' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, name As String)
Dim tgt As Worksheet
Dim MyRange As Range
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
Else
If Series = " " Then
End
End If
End If
Worksheets("FormulaMSheet2").Activate
' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
Worksheets("FormulaMSheet2").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
Set tgt = Sheets(name)
' copy data from src to tgt
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Variant
For Each ws In ThisWorkbook.Sheets
If ws.name = name Then
SheetExists = True
Exit Function
End If
Next
SheetExists = False
End Function
You need replace the
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value
to
src.Range("A" & Start & ":BO" & Last).SpecialCells(xlCellTypeVisible).Copy Destination:=tgt.Range("A2:BO2" & Last - Start + 2)
I found what I needed at the following site: http://www.rondebruin.nl/win/s3/win006_5.htm .
I figured if anyone else was looking for similar code it would help taking a look at the site.

Need to find the last row in a spreadsheet before copying and pasting data from Sheet 1 to Sheet 2

This site has helped me immensely with VBA for a while now, so thanks for that! But I just can't seem to get this code to work and I've look at so many examples. What's happening is that I'm archiving data on another sheet once the current date is 4 days ahead of the due date. Everything works like it should, but every time the macro executes, the data on sheet2 is erased and copied over. I need my code to find the last row on sheet2 and copy the data from sheet1 to sheet2 so all the data is there. Thanks!
Sub archive()
Dim LastRow As Long
Dim i As Long
LastRow = Range("M" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If Worksheets("Sheet1").Range("M" & i) - Date <= -4 And Worksheets("Sheet1").Range("N" & i).Value = "DONE" Then
Sheet2.Select
Range("A" & i).EntireRow.Value = Sheet1.Range("M" & i).EntireRow.Value
Sheet1.Range("M" & i).EntireRow.Delete
End If
If Worksheets("Sheet1").Range("L" & i) = "" Then
Exit For
End If
Next i
End Sub
Here I've taken your code and changed it to use worksheet objects. I've not tested this on any data as you haven't provided any to use, but it gives you an idea of how to implement it.
Also, in your code you weren't finding the last row of Sheet2, you were putting the data in row i, which starts at 3.
You also need to watch out when you delete the row of data from sheet1, as this shifts the rest of the data up, so the next iteration of the loop may not find the next row of data/ skip a row of data.
Sub archive()
Dim LastRow As Long
Dim LastRowSht2 As Long
Dim i As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim rowCount As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
LastRow = sht1.Range("M" & Rows.Count).End(xlUp).Row
rowCount = 3
For i = 3 To LastRow
If sht1.Range("M" & rowCount) - Date <= -4 And sht1.Range("N" & rowCount).Value = "DONE" Then
LastRowSht2 = sht2.Range("A" & Rows.Count).End(xlUp).Row + 1 '+1 so it doesn't overwrite the last row
sht2.Range("A" & LastRowSht2).EntireRow.Value = sht1.Range("M" & rowCount).EntireRow.Value
sht1.Range("M" & rowCount).EntireRow.Delete
Else
rowCount = rowCount + 1
End If
If sht1.Range("L" & rowCount) = "" Then
Exit For
End If
Next i
' clean up
set sht1 = nothing
set sht2 = nothing
End Sub