castlefamily
09-16-2019, 09:09 AM
So I come to the Gurus again needing help. I am attaching the workbook so that you can see what I am doing. I am responsible for rail car inspections. I have been able with help to write a macro that allows me to put an X in column J and that move those cars and their info to the inspection sheet. The problem that I am having is this: the cars come into the yard in a certain order. Meaning that when I inspect them the sheet has to stay in the order that the arrive. Right now, when I put the X it automatically puts them in order by date, and that isn't usable for my work. Is there a way that the order I put the X in will be the order that they show up on the inspection screen?
Here is the current code:
Sub Transfer()
Dim wshS As Worksheet
Dim wshT As Worksheet
Dim rng As Range
Dim strAddress As String
Dim s As Long
Dim t As Long
Application.ScreenUpdating = False
Set wshT = Worksheets("Inspection")
t = wshT.Range("B" & wshT.Rows.Count).End(xlUp).Row
If t < 4 Then t = 4
For Each wshS In Worksheets
If wshS.Name <> wshT.Name Then
Set rng = wshS.Range("J:J").Find(What:="1", LookAt:=xlWhole)
If Not rng Is Nothing Then
strAddress = rng.Address
Do
t = t + 1
s = rng.Row
wshS.Range("A" & s & ",B" & s).Copy _
Destination:=wshT.Range("B" & t)
wshS.Range("F" & s).Copy _
Destination:=wshT.Range("D" & t)
wshS.Range("D" & s).Copy _
Destination:=wshT.Range("E" & t)
Set rng = wshS.Range("J:J").FindNext(After:=rng)
If rng Is Nothing Then Exit Do
Loop Until rng.Address = strAddress
End If
End If
Next wshS
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Also the workbook is attached and has been approved by my company to be posted as it does not contain sensitive material.
Thank you all for the help.
Dustin
Here is the current code:
Sub Transfer()
Dim wshS As Worksheet
Dim wshT As Worksheet
Dim rng As Range
Dim strAddress As String
Dim s As Long
Dim t As Long
Application.ScreenUpdating = False
Set wshT = Worksheets("Inspection")
t = wshT.Range("B" & wshT.Rows.Count).End(xlUp).Row
If t < 4 Then t = 4
For Each wshS In Worksheets
If wshS.Name <> wshT.Name Then
Set rng = wshS.Range("J:J").Find(What:="1", LookAt:=xlWhole)
If Not rng Is Nothing Then
strAddress = rng.Address
Do
t = t + 1
s = rng.Row
wshS.Range("A" & s & ",B" & s).Copy _
Destination:=wshT.Range("B" & t)
wshS.Range("F" & s).Copy _
Destination:=wshT.Range("D" & t)
wshS.Range("D" & s).Copy _
Destination:=wshT.Range("E" & t)
Set rng = wshS.Range("J:J").FindNext(After:=rng)
If rng Is Nothing Then Exit Do
Loop Until rng.Address = strAddress
End If
End If
Next wshS
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Also the workbook is attached and has been approved by my company to be posted as it does not contain sensitive material.
Thank you all for the help.
Dustin