excel macro code is skipping every 2nd line - vba

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")

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

Check if there is empty Range in vba

I am trying to filter by a list of Condition from the Condition wb to use for the Order wb. I use a checkEmpty range in order to check if there are no matching value then I will clear the filter and start with the next condition. But my code doesn't work and the error is "Range of object_worksheet" failed.
I get the error because even there is no matching value (empty range), the code still jump to Else condition.
Here is my code:
Sub Order()
Dim start As Double
Dim strKeyWord As String
Dim myCount As Integer
Dim checkEmpty As Range
Dim lRow1 As Long
Dim wsOrder As Worksheet
Dim wsCondition As Worksheet
Dim wbOrder As Workbook
Dim wbCondition As Workbook
Dim OrderFile As String
Dim ConditionFile As String
'Open Order wb
OrderFile = Application.GetOpenFilename()
Set wbOrder = Workbooks.Open(OrderFile)
Set wsOrder = wbOrder.Worksheets(1)
'Open Condition wb
ConditionFile = Application.GetOpenFilename()
Set wbCondition = Workbooks.Open(ConditionFile)
Set wsCondition = wbCondition.Worksheets(1)
'using the CountA ws function (all non-blanks)
myCount = Application.CountA(wsCondition.Range("A:A")) - 1
start = 2
For I = 1 To myCount Step 1
strKeyWord = wsCondition.Range("A" & start)
wsOrder.Range("R:R").AutoFilter Field:=1, Criteria1:="=*" & strKeyWord & "*"
'lRow1 = WorksheetFunction.Max(wsOrder.Range("I65536").End(xlUp).Row)
Set checkEmpty = wsOrder.Range("I2:I100").SpecialCells(xlCellTypeVisible)
If checkEmpty Is Nothing Then
On Error Resume Next
wsOrder.ShowAllData
On Error GoTo 0
Else
wsOrder.Range("I2", Range("I" & Rows.Count).End(xlUp)).Copy
With wsCondition
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial
End With
End If
start = start + 1
Next I
End Sub
Thank you very much!
So the main issue is that you didn't specify a worksheet for Range("I" & Rows.Count).End(xlUp).
Using
wsOrder.Range("I2", Range("I" & wsOrder.Rows.Count).End(xlUp)).Copy
should fix that.
But also I would correct the For I loop because you never use I. But you don't need the start variable and can use I instead which is also auto incremented.
'using the CountA ws function (all non-blanks)
myCount = Application.CountA(wsCondition.Range("A:A")) 'removed the -1
'remove start=2 and replace start with I
For I = 2 To myCount Step 1
strKeyWord = wsCondition.Range("A" & I)
wsOrder.Range("R:R").AutoFilter Field:=1, Criteria1:="=*" & strKeyWord & "*"
'lRow1 = WorksheetFunction.Max(wsOrder.Range("I65536").End(xlUp).Row)
Set checkEmpty = wsOrder.Range("I2:I100").SpecialCells(xlCellTypeVisible)
If checkEmpty Is Nothing Then
On Error Resume Next
wsOrder.ShowAllData
On Error GoTo 0
Else
wsOrder.Range("I2", Range("I" & Rows.Count).End(xlUp)).Copy
With wsCondition
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial
End With
End If
Next I

Need to transpose rows while transferring data from one excel sheet to another

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

EXCEL-VBA hyperlinks conversion inquiry

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

Copy a variable range from other files to a summary sheet

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...