J
jlclyde
Below is the code that i have been slowly adding to to accomplish a
task of moving all of this information to another sheet. The two
sheets that I have are RA and inspect form and copysheet. The code
runs great until the last two lines. I can not figure out why it is
throwing an error.
Thanks,
Jay
Sub addsheet()
Dim form As Worksheet
Dim copy1 As Worksheet
Dim NextRow As Long
Dim rCount As Integer
Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move After:=Worksheets(Worksheets.Count)
.Name = "copysheet"
End With
Set form = Sheets("RA and inspect Form")
NextRow = form.Range("A10").End(xlDown).Row
Set copy1 = Sheets("copysheet")
form.Range("A10").Resize(NextRow - 9, 8).copy
copy1.Range("A1").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
copy1.Cells.Sort _
Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess,
OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
Key2:=Range("F1"), Order1:=xlAscending, Header:=xlGuess,
OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal
rowCount = 1
Do While Range("A" & rowCount) <> "" And Range("F" & rowCount) <>
""
If Range("B" & rowCount) = Range("B" & (rowCount + 1)) _
And Range("F" & rowCount) = Range("F" & (rowCount + 1)) Then
Data = Range("A" & (rowCount + 1))
Data2 = Range("B" & (rowCount + 1))
Data3 = Range("C" & (rowCount + 1))
Data4 = Range("D" & (rowCount + 1))
Data5 = Range("E" & (rowCount + 1))
Data6 = Range("F" & (rowCount + 1))
If Range("A" & rowCount) = "" And Range("F" & rowCount) = ""
Then
Range("A" & rowCount) = Data
Range("B" & rowCount) = Data2
Range("C" & rowCount) = Data3
Range("D" & rowCount) = Data4
Range("E" & rowCount) = Data5
Range("F" & rowCount) = Data6
Else
Range("A" & rowCount) = Range("A" & rowCount) & ", " &
Data
Range("B" & rowCount) = Range("B" & rowCount)
Range("C" & rowCount) = Range("C" & rowCount) & ", " &
Data3
Range("D" & rowCount) = Range("D" & rowCount) & ", " &
Data4
Range("E" & rowCount) = Range("E" & rowCount) + Data5
Range("F" & rowCount) = Range("F" & rowCount)
End If
Rows(rowCount + 1).Delete
Else
rowCount = rowCount + 1
End If
Loop
copy1.Range("A:A").Cut copy1.Range("H:H")
copy1.Range("F:F").Cut copy1.Range("I:I")
copy1.Range("B:B").Cut copy1.Range("O:O")
copy1.Range("E:E").Cut copy1.Range("Q:Q")
copy1.Range("C:C").Cut copy1.Range("F:F")
copy1.Range("D").Cut copy1.Range("G:G")
rCount = copy1.UsedRange.Rows.Count
Range(Range("A1"), Range("A" & rCount)).NumberFormat = "mm/dd/
yyyy"
Range(Range("A1"), Range("A" & rCount)) = form.Range("B1")
Range(Range("C1"), Range("C" & rCount)) = form.Range("B2")
Range(Range("L1"), Range("L" & rCount)) = form.Range("G2")
Range(Range("M1"), Range("M" & rCount)) = form.Range("B5")
Range(Range("N1"), Range("N" & rCount)) = form.Range("B7")
Dim rFound As Range
With Sheets("RA and inspect form")
Set rFound = .Columns(1).Find(What:="Inspection Notes", _
After:=.Cells(1, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If Not rFound Is Nothing Then
.Activate
End If
End With
Dim department, empname As Range
Set department = rFound.Offset(27, 1)
Set empname = rFound.Offset(27, 2)
copy1.Range(Range("J1"), Range("J" & rCount)) = department
copy1.Range(Range("K1"), Range("J" & rCount)) = empname
End Sub
task of moving all of this information to another sheet. The two
sheets that I have are RA and inspect form and copysheet. The code
runs great until the last two lines. I can not figure out why it is
throwing an error.
Thanks,
Jay
Sub addsheet()
Dim form As Worksheet
Dim copy1 As Worksheet
Dim NextRow As Long
Dim rCount As Integer
Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move After:=Worksheets(Worksheets.Count)
.Name = "copysheet"
End With
Set form = Sheets("RA and inspect Form")
NextRow = form.Range("A10").End(xlDown).Row
Set copy1 = Sheets("copysheet")
form.Range("A10").Resize(NextRow - 9, 8).copy
copy1.Range("A1").PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
copy1.Cells.Sort _
Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess,
OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
Key2:=Range("F1"), Order1:=xlAscending, Header:=xlGuess,
OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal
rowCount = 1
Do While Range("A" & rowCount) <> "" And Range("F" & rowCount) <>
""
If Range("B" & rowCount) = Range("B" & (rowCount + 1)) _
And Range("F" & rowCount) = Range("F" & (rowCount + 1)) Then
Data = Range("A" & (rowCount + 1))
Data2 = Range("B" & (rowCount + 1))
Data3 = Range("C" & (rowCount + 1))
Data4 = Range("D" & (rowCount + 1))
Data5 = Range("E" & (rowCount + 1))
Data6 = Range("F" & (rowCount + 1))
If Range("A" & rowCount) = "" And Range("F" & rowCount) = ""
Then
Range("A" & rowCount) = Data
Range("B" & rowCount) = Data2
Range("C" & rowCount) = Data3
Range("D" & rowCount) = Data4
Range("E" & rowCount) = Data5
Range("F" & rowCount) = Data6
Else
Range("A" & rowCount) = Range("A" & rowCount) & ", " &
Data
Range("B" & rowCount) = Range("B" & rowCount)
Range("C" & rowCount) = Range("C" & rowCount) & ", " &
Data3
Range("D" & rowCount) = Range("D" & rowCount) & ", " &
Data4
Range("E" & rowCount) = Range("E" & rowCount) + Data5
Range("F" & rowCount) = Range("F" & rowCount)
End If
Rows(rowCount + 1).Delete
Else
rowCount = rowCount + 1
End If
Loop
copy1.Range("A:A").Cut copy1.Range("H:H")
copy1.Range("F:F").Cut copy1.Range("I:I")
copy1.Range("B:B").Cut copy1.Range("O:O")
copy1.Range("E:E").Cut copy1.Range("Q:Q")
copy1.Range("C:C").Cut copy1.Range("F:F")
copy1.Range("D").Cut copy1.Range("G:G")
rCount = copy1.UsedRange.Rows.Count
Range(Range("A1"), Range("A" & rCount)).NumberFormat = "mm/dd/
yyyy"
Range(Range("A1"), Range("A" & rCount)) = form.Range("B1")
Range(Range("C1"), Range("C" & rCount)) = form.Range("B2")
Range(Range("L1"), Range("L" & rCount)) = form.Range("G2")
Range(Range("M1"), Range("M" & rCount)) = form.Range("B5")
Range(Range("N1"), Range("N" & rCount)) = form.Range("B7")
Dim rFound As Range
With Sheets("RA and inspect form")
Set rFound = .Columns(1).Find(What:="Inspection Notes", _
After:=.Cells(1, 1), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
If Not rFound Is Nothing Then
.Activate
End If
End With
Dim department, empname As Range
Set department = rFound.Offset(27, 1)
Set empname = rFound.Offset(27, 2)
copy1.Range(Range("J1"), Range("J" & rCount)) = department
copy1.Range(Range("K1"), Range("J" & rCount)) = empname
End Sub