Snasui Excel Forum

Code: Select all

Sub cJs()

'Define abbreviations for worksheets
    Dim WI As Worksheet
    Dim WF As Worksheet
    Set WI = Worksheets("SIMB")
    Set WF = Worksheets("Result")
    
    Dim AmountCell1 As Range
    Dim HeadingRow1 As Integer
    Dim CurrentRow1 As Integer
    
        HeadingRow1 = WF.Range("FormsFirstLine1").Row
    CurrentRow1 = HeadingRow1
    
        For Each AmountCell1 In WI.Range("InputDoctorfree").Cells
        If AmountCell1 <> "" Then
            WF.Cells(HeadingRow1, 6) = ""
            CurrentRow1 = CurrentRow1 + 1
           WF.Cells(CurrentRow1, 1) = AmountCell1.Text
           WF.Cells(CurrentRow1, 2) = AmountCell1.Offset(0, 1)
       
        End If
    Next
    
    
End Sub

Code: Select all

Sub test0()
    Dim arr(999, 1) As Variant, i As Integer, l As Long
    Dim rall As Range, ra As Range, r As Range
    With Worksheets("SIMB")
        Set rall = .Range("a2", .Range("a" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeConstants)
        For i = 1 To rall.Areas.Count
            If Application.Sum(rall.Areas(i).Offset(0, 1)) <> 0 Then
                Set ra = rall.Areas(i).Cells
                For Each r In ra
                    If VBA.Mid(r.Value, 3, 1) <> " " Or r.Offset(0, 1).Value <> "" Then
                        arr(l, 0) = r.Value
                        arr(l, 1) = r.Offset(0, 1).Value
                        l = l + 1
                    End If
                Next r
            End If
            l = l + 1
        Next i
    End With
    If l > 0 Then
        Worksheets("Result").Range("a2").Resize(l, 2).Value = arr
    End If
End Sub

Code: Select all

Sub cJs()


    Dim arr(999, 1) As Variant, i As Integer, l As Long
    Dim rall As Range, ra As Range, r As Range
    With Worksheets("SIMB")
        Set rall = .Range("a2", .Range("a" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeConstants)
        For i = 1 To rall.Areas.Count
            If Application.Sum(rall.Areas(i).Offset(0, 1)) <> 0 Then
                Set ra = rall.Areas(i).Cells
                For Each r In ra
                    If VBA.Mid(r.Value, 3, 1) <> " " Or r.Offset(0, 1).Value <> "" Then
                        arr(l, 0) = r.Value
                        arr(l, 1) = r.Offset(0, 1).Value
                        l = l + 1
                    End If
                Next r
            End If
            l = l + 1
        Next i
    End With
    If l > 0 Then
        Worksheets("Result").Range("a2").Resize(l, 2).Value = arr
    End If
    
        Dim arr2(999, 1) As Variant, t As Integer, y As Long
    Dim rall2 As Range, ra2 As Range, s As Range
    With Worksheets("SIMB")
    
        Set rall2 = .Range("d2", .Range("d" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeConstants)
        For t = 1 To rall2.Areas.Count
            If Application.Sum(rall2.Areas(t).Offset(0, 2)) <> 0 Then
                Set ra2 = rall2.Areas(t).Cells
                For Each s In ra2
                    If VBA.Mid(s.Value, 3, 1) <> "0" Or s.Offset(0, 3).Value <> "0" Then
                        arr2(y, 0) = s.Value
                        arr2(y, 1) = s.Offset(0, 1).Value
                        y = y + 1
                    End If
                Next s
            End If
            y = y + 1
        Next t
    End With
    If y > 0 Then
        Worksheets("Result").Range("d2").Resize(y, 2).Value = arr2
    End If
End Sub

Code: Select all

'Other code...
Dim arr2(999, 2) As Variant, y As Long
    Dim rall2 As Range, s As Range
    With Worksheets("SIMB")
        Set rall2 = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
        For Each s In rall2
            If s.Offset(0, 2).Value <> 0 Then
                arr2(y, 0) = s.Value
                arr2(y, 1) = s.Offset(0, 1).Value
                arr2(y, 2) = s.Offset(0, 2).Value
                y = y + 1
            End If
        Next s
    End With
    If y > 0 Then
        Worksheets("Result").Range("d2").Resize(y, 3).Value = arr2
    End If
'Other code...

Code: Select all

'Other code
With Worksheets("SIMB")
    Set rall = .Range("a2", .Range("a" & .Rows.Count).End(xlUp)) _
        .SpecialCells(xlCellTypeConstants)
    For i = 1 To rall.Areas.Count
        If Application.Sum(rall.Areas(i).Offset(0, 1)) <> 0 Then
            Set ra = rall.Areas(i).CurrentRegion.Resize(, 1)
'Other code