This code is to open files and go to a certain sheet, grab everything from A11 to AC(down), go back to a report and progressively paste it one after the other, which works with the exception that it can't find the next available row so it pastes the new data over the previous data. I am quite sure that my efforts with LastRowSrce and LastRowDest is the culprit but I can't get it right. I saw some posts with UsedRange so I tried that but couldn't get it right either.
Any help greatly appreciated.
Sub CSReport()
Dim y As Long
Dim Wkb As Workbook
Dim Wks As Worksheet
Dim SFile As String 'srce file
Dim GWB As String 'dest file
Dim R1 As Range
Dim R2 As Range
Dim LastRowSrce As Long 'find last row in srce file
Dim LastRowDest As Long 'find last row in dest file
Set Wkb = thisWorkBook
Set Wks = Wkb.Worksheets("CS Report")
Wks.Range("A11:AD10000").ClearContents
Wks.Range("A4").value = "Status at " & Time & " " & Format(Date, "Long date")
y = 11 'start row
SFile = Wkb.Path & "\"
GWB = Dir(SFile & "*Audit*")
Do While Len(GWB) > 0
workbooks.Open fileName:=SFile & GWB
LastRowSrce = workbooks(GWB).Worksheets("Audit Plan").Cells(Rows.Count, "A").End(xlUp).Row
LastRowDest = Wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
Set R1 = workbooks(GWB).Worksheets("Audit Plan").Range("A" & y & ":AB" & LastRowSrce)
Set R2 = Wks.Range("A" & y & ":AB" & LastRowSrce)
R2.value = R1.value
workbooks(GWB).Close False
y = y + 1
GWB = Dir
Loop
Wkb.Save
End Sub
Set R2 = Wks.Range("A" & y & ":AB" & LastRowSrce)
you keep setting the same range on the destination sheet... you need it to be dynamic.
set R2 = Wks.Range("A" & LastRowDest & ":AB" & LastRowDest+LastRowSrce-11)
try that...
Related
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
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 =
My original question was posted here.
Basically I needed some help transferring data from one sheet to another based on values in the first sheet. I am using a modified bit of code provided by user keong kenshih.
I added an additional check against another row to the IF statement, and I have this for my code:
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyOutputWorksheet As Worksheet
So I need to output only certain columns. Also I need them to import to certain rows and columns on the second sheet, the CONTRACT sheet. Column A on the MAIN sheet goes to column A starting at row 17 on the CONTRACT sheet. B to B , E to D, F to E, all starting at row 17 on the CONTRACT sheet.
Rows 17-42 on the CONTRACT sheet will contain data.
Sub PullData()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("MAIN")
Set MyOutputWorksheet = MyWorkbook.Sheets("CONTRACT")
Dim myValue As Long
Dim RowPointer As Long
For RowPointer = 6 To MyWorksheet.Cells(Rows.Count, "B").End(xlUp).Row
If MyWorksheet.Range("A" & RowPointer).V alue > 0 And
MyWorksheet.Range("A" & RowPointer).Value <> ""
MyWorksheet.Range("F" & RowPointer).Value > 0 And
MyWorksheet.Range("F" & RowPointer).Value <> ""Then
If MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row > 15
Then
Exit Sub
End If
MyWorksheet.Range(("A" & RowPointer) & ":C" & RowPointer).Copy
Destination:=MyOutputWorksheet.Range("A" &
MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row + 1)
End If
Next RowPointer
End Sub
Give this a try :
Sub PullData()
Dim wRow As Long, _
RowPointer As Long, _
MyWorkbook As Workbook, _
Ws As Worksheet, _
OutWs As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set Ws = MyWorkbook.Sheets("MAIN")
Set OutWs = MyWorkbook.Sheets("CONTRACT")
With Ws
For RowPointer = 6 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Range("A" & RowPointer).Value > 0 And _
.Range("A" & RowPointer).Value <> "" And _
.Range("F" & RowPointer).Value > 0 And _
.Range("F" & RowPointer).Value <> "" Then
'This line would get you out of the loop after the first copy because _
'You first paste on line 17 and then the below left part will be equal to 18
'If OutWs.Cells(OutWs.Rows.Count, "B").End(xlUp).Row > 15 Then Exit Sub
wRow = OutWs.Rows(OutWs.Rows.Count).End(xlUp).Row + 1
'Always start copy after (or at) line 17
If wRow <= 17 Then wRow = 17
'More efficient way to copy data between ranges
OutWs.Range("A" & wRow).Value = Ws.Range("A" & RowPointer)
OutWs.Range("B" & wRow).Value = Ws.Range("B" & RowPointer)
OutWs.Range("D" & wRow).Value = Ws.Range("E" & RowPointer)
OutWs.Range("E" & wRow).Value = Ws.Range("F" & RowPointer)
End If
Next RowPointer
End With
Set MyWorkbook = Nothing
Set Ws = Nothing
Set OutWs = Nothing
End Sub
Dim RITMRow As Long
Dim ws1 As Worksheet
Dim RITMstorage As String
Dim LastRow As Long
Set ws1 = Sheets("Tracker")
LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
For RITMRow = 2 To LastRow
RITMstorage = ws1.Range("A" & RITMRow).Value
ws1.Range("A" & RITMRow).Hyperlinks.Add Anchor:=ws1.Range("A" & RITMRow), _
Address:="https://site.site.com/sc_req_item.do?sys_id=" & RITMstorage, _
ScreenTip:="Request Number", _
TextToDisplay:=RITMstorage
Next RITMRow
With ws1
.Cells.Font.Size = "8"
.Cells.RowHeight = 11.25
.Cells.Font.Name = "Calibri"
.Range("A1").EntireRow.RowHeight = 25
End With
hi, my code above works in converting a column to hyperlinks. as you can see, it's quite a bit inefficient as everytime i click the button, it goes back and converts everything to hyperlinks again, even those that are already hypelinks. please point me in the right direction. i need a way to detect the columns that already has a hyperlink the offset by 1 then convert the non hyperlink cell.
thanks in advance.
Just try to get the address from the cell and check to see if you get an error:
Dim url As String
Dim isLink As Boolean
For RITMRow = 2 To LastRow
On Error Resume Next
url = ws1.Range("A" & RITMRow).Hyperlinks(1).SubAddress
isLink = (Err.Number = 0)
On Error GoTo 0
If Not isLink Then
RITMstorage = ws1.Range("A" & RITMRow).Value
ws1.Range("A" & RITMRow).Hyperlinks.Add Anchor:=ws1.Range("A" & RITMRow), _
Address:="https://site.site.com/sc_req_item.do?sys_id=" & RITMstorage, _
ScreenTip:="Request Number", _
TextToDisplay:=RITMstorage
End If
Next RITMRow
the below code is to take an employee name, (Column A) andput the range ("A:J") of that row into a new sheet of that employee, if they dont have a sheet, then make one and ad the heading. However, it is skipping every second line, which is causing the line that it is scanning the name on, and the line it is copying from to be different (ie:Employees are going in the wrong sheets, and only 1/2 are getting moved)
Any help would be great
Set rngEmpSales = wsSales.Range("A2", wsSales.Range("A" & Rows.Count).End(xlUp).Address)
Dim wsSales As Worksheet, wsDesSales As Worksheet
Set wsSales = ThisWorkbook.Sheets("Sales")
Dim SalesCount as Range
For Each SalesCount In rngEmpSales
On Error Resume Next
Set wsDesSales = ThisWorkbook.Sheets(Trim(SalesCount.Value))
On Error GoTo 0
If wsDesSales Is Nothing Then
Set wsDesSales = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsDesSales.Name = SalesCount.Value
End If
SalesCount(1 - (SalesCount.Row - 1)).Range("A1:J1").Copy wsDesSales.Range("K2")
SalesCount.Range("A" & SalesCount.Row & ":J" & SalesCount.Row).Copy wsDesSales.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
Set wsDesSales = Nothing
End If
Next SalesCount
Is this what you are trying? (UNTESTED)
Sub Sample()
Dim wsSales As Worksheet, wsDesSales As Worksheet
Dim rngEmpSales As Range, SalesCount As Range
Dim shName As String
Dim lRow As Long, i As Long
Set wsSales = ThisWorkbook.Sheets("Sales")
With wsSales
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngEmpSales = .Range("A2:A" & lRow)
For i = 2 To lRow
shName = Trim(.Range("A" & i).Value)
On Error Resume Next
Set wsDesSales = ThisWorkbook.Sheets(shName)
On Error GoTo 0
If wsDesSales Is Nothing Then
Set wsDesSales = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsDesSales.Name = shName
End If
.Range("A1:J1").Copy wsDesSales.Range("K2")
.Range("A" & i & ":J" & i).Copy wsDesSales.Range("K" & _
wsDesSales.Rows.Count).End(xlUp).Offset(1, 0)
Set wsDesSales = Nothing
Next i
End With
End Sub
You should use
wssales.Range("A" & SalesCount.Row & ":J" & SalesCount.Row) instead of SalesCount.Range("A" & SalesCount.Row & ":J" & SalesCount.Row)
and
wssales.Range("A1:J1").Copy instead of
SalesCount(1 - (SalesCount.Row - 1)).Range("A1:J1").Copy
The reason is SalesCount itself is a range, when you apply another .Range after it, it will take the relative position.
e.g. Range("A2").Range("A1:J1") becomes Range("A2:J2") and Range("B2").Range("B2:K2") becomes Range("B2:K2")