Snasui Excel Forum

Code: Select all

Sub CopyPartCode()
    Dim nvalue As Long
    Application.ScreenUpdating = False
    Range("A1").Select
    nrow = 4
    Do Until ActiveCell.Offset(1, 0).Value = ""
            With ActiveCell
                    If Len(ActiveCell.Value) = 13 Then
                            Sheets("schedule").Cells(nrow, 1).Value = .Value
                            Set arange = Range(ActiveCell.Offset(1, 6), ActiveCell.Offset(1, 6).End(xlDown))
                            For Each a In arange
                                    tvalue = Left(a.Value, 2)
                                    If tvalue = "" Then Exit For
                                    nvalue = Left(a.Value, 2)
                                    For Each b In Sheets("schedule").Range("c2:ag2")
                                            If nvalue = b.Value Then
                                                Sheets("schedule").Cells(nrow, nvalue + 2).Value = "D"
                                                Exit For
                                            End If
                                    Next b
                            Next a
                            ActiveCell.Offset(1, 0).Select
                            nrow = nrow + 1
                        Else
                            ActiveCell.Offset(1, 0).Select
                    End If
            End With
    Loop
     MsgBox ("Process Completed!")
     Sheets("schedule").Select
End Sub

Code: Select all

Sub CopyPartCode()
    Dim nvalue As Integer
    Dim arange As Range
    Dim r As Range
    Dim tvalue As Integer
    Application.ScreenUpdating = False
    nrow = 4
    With Sheets("data")
        Set arange = .Range("a2", .Range("a" & .Rows.Count).End(xlUp)).Offset(0, 6)
    End With
    For Each r In arange
            If Len(r.Offset(0, -6).Value) = 13 Then
                    Sheets("schedule").Cells(nrow, 1).Value = r.Offset(0, -6).Value
                    For Each a In arange
                            tvalue = Left(a.Value, 2)
                            If IsEmpty(tvalue) Then Exit For
                            nvalue = Left(a.Offset(0, -1).Value, 2)
                            For Each b In Sheets("schedule").Range("c2:ag2")
                                    If tvalue = b.Value Then
                                        Sheets("schedule").Cells(nrow, b.Column).Value = "D"
                                    ElseIf nvalue = b.Value Then
                                        Sheets("schedule").Cells(nrow, b.Column).Value = "R"
                                    End If
                            Next b
                    Next a
                    nrow = nrow + 1
            End If
    Next r
    Application.ScreenUpdating = True
     MsgBox ("Process Completed!")
     Sheets("schedule").Select
End Sub

Code: Select all

'Other code
tvalue = Left(r.Value, 2)
If IsEmpty(tvalue) Then Exit For
nvalue = Left(r.Offset(0, -1).Value, 2)
'Other code

Code: Select all

Sub test()
Dim lr As Long, r As Range
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
With Sheets("Data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("H1").Value = "R"
    .Range("I1").Value = "D"
    For Each r In .Range("F2:F" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    For Each r In .Range("G2:G" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    .Range("A2:A" & lr).Copy Sheets("Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("H1:I" & lr).Copy Sheets("Schedule").Range("AH3")
    .Columns("H:I").ClearContents
End With
lr = Range("A" & Rows.Count).End(xlUp).Row
lc = Cells(3, Columns.Count).End(xlToLeft).Column - 2
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 34) = Cells(2, j) Then
            Cells(i, j).Value = "R"
        End If
    Next j
Next i
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 35) = Cells(2, j) Then
            Cells(i, j).Value = "D"
        End If
    Next j
Next i
Columns("AH:AI").ClearContents
Application.ScreenUpdating = True
End Sub

Code: Select all

Sub test()
Dim lr As Long, r As Range
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
With Sheets("Data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("H1").Value = "R"
    .Range("I1").Value = "D"
    For Each r In .Range("F2:F" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    For Each r In .Range("G2:G" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    .Range("A2:A" & lr).Copy Sheets("Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("H1:I" & lr).Copy Sheets("Schedule").Range("AH3")
    .Columns("H:I").ClearContents
End With
Sheets("schedule").Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
lc = Cells(3, Columns.Count).End(xlToLeft).Column - 2
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 34) = Cells(2, j) Then
            Cells(i, j).Value = "R"
        End If
    Next j
Next i
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 35) = Cells(2, j) Then
            Cells(i, j).Value = "D"
        End If
    Next j
Next i
Columns("AH:AI").ClearContents
Application.ScreenUpdating = True
End Sub

Code: Select all

 Sub DeleteDups()
     
    Dim x               As Long
    Dim LastRow         As Long
     
    LastRow = Range("A65536").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
     
End Sub