castlefamily
09-12-2019, 09:34 AM
Hello all,
I wrote this code with a lot of headaches and help, but I am at a problem. I was not aware that I would need the columns to copy to the new sheet in a specific order. Right now the code allows me to put an x on any sheet and that copies columns A,B,D,F of the row marked. I need the order to be A,B,F,D. I have tried changing the order in the range, as well as setting cells equal, but I am in over my head. Here is the 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:="X", LookAt:=xlWhole)
If Not rng Is Nothing Then
strAddress = rng.Address
Do
t = t + 1
s = rng.Row
wshS.Range("A" & s & ",B" & s & ",D" & s & ",F" & s).Copy _
Destination:=wshT.Range("B" & t)
' Optional: clear the "X"
wshS.Range("J" & s).ClearContents
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
Any help would be appreciated
I wrote this code with a lot of headaches and help, but I am at a problem. I was not aware that I would need the columns to copy to the new sheet in a specific order. Right now the code allows me to put an x on any sheet and that copies columns A,B,D,F of the row marked. I need the order to be A,B,F,D. I have tried changing the order in the range, as well as setting cells equal, but I am in over my head. Here is the 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:="X", LookAt:=xlWhole)
If Not rng Is Nothing Then
strAddress = rng.Address
Do
t = t + 1
s = rng.Row
wshS.Range("A" & s & ",B" & s & ",D" & s & ",F" & s).Copy _
Destination:=wshT.Range("B" & t)
' Optional: clear the "X"
wshS.Range("J" & s).ClearContents
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
Any help would be appreciated