Extract Data from a Table with Macro/VBA

[acerlaptop]

Hi All,

I Have a table and Macro code below. What I want to do is:
-Copy all numbers to a worksheet named "TEST" (Helper worksheet)
-Criteria are:
1. If Header of Column is "Total" - End VBA
2. Start with Range(E2) then if value is "-" or if Value of Cells(activerow, 2) = blank then select next row
3. If activerow is greater than LastRow, select next column row 2.
4. if Value is not "-" or if Value of Cells(activerow, 2) is NOT blank, then copy activecell to worksheet(test) range(A & LastRowT + 1)

But the macro just keeps runnig without ending.

Any ideas?

Thanks

Sub Test()
Application.ScreenUpdating = False
Dim aC As Integer
Dim aR As Integer
Dim ActiveC As Range
Dim LastRow As Integer
Dim LastrowT As Integer

Sheets.Add
ActiveSheet.Name = "TEST"

Sheets("Booking").Activate
Range("E2").Select

LastRow = Worksheets("Booking").Cells(Rows.Count, 1).End(xlUp).Row
aR = ActiveCell.Row
aC = ActiveCell.Column
Set ActiveC = Cells(aR, aC)

Do While True
    If Cells(1, aC) = "Total" Then
        Exit Do
    Else
        If aR > LastRow Then
            Range(aC + 1 & "2").Select
        Else
            If Selection.Value = "-" Or Cells(aR, 2) = "" Then
                Selection.Offset(1, 0).Select
            Else
                LastrowT = Worksheets("TEST").Cells(Rows.Count, 1).End(xlUp).Row
                ActiveC.copy
                Worksheets("TEST").Range("A" & LastrowT + 1).PasteSpecial xlPasteValues
            End If
        End If
    End If
Loop
Application.ScreenUpdating = True
End Sub

 

[mse330]

Hello acerlaptop,

I think your issue is you don't have "-" in your data but rather a "zero" formatted as "-" so your loop keeps copying the cell E2 endlessly. Few tips based on your code

1. As a general rule in VBA, you hardly need to 'select' any cell as it just unnecessarily slows down your code
2. You can directly assign the value of a cell/range to another without the need to copy/paste
3. Instead of looping through each cell, you can consider the whole range
4. You can debug your code (comment the Application.ScreenUpdating = False) then press F8 to see what's happening line by line

I can't see what's the purpose of your code as it just adds all the numbers greater than zero but without any descriptions, is this a practice or you need to further have some other code ?

Try the below code see if it does what you need - I have added some comments for you

Sub aa()

Dim Lr As Long

'check if sheets exists clear data if doesn't create one
If Evaluate("isref(TEST!A1)") Then Sheets("TEST").UsedRange.Clear Else Sheets.Add.Name = "TEST"

With Sheets("Booking")
   Lr = .UsedRange.Rows.Count
   For x = 5 To 14 'loop from column 5 (E) to column 14 (N)
      Sheets("TEST").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Lr) = .Cells(2, x).Resize(Lr).Value
   Next
End With

With Sheets("TEST").Columns(1)
   .Replace 0, "", lookat:=xlWhole                  'replace all 0 values with blank
   .SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete all blank rows
End With

End Sub

 

[acerlaptop]

Hello acerlaptop,

I think your issue is you don't have "-" in your data but rather a "zero" formatted as "-" so your loop keeps copying the cell E2 endlessly. Few tips based on your code

1. As a general rule in VBA, you hardly need to 'select' any cell as it just unnecessarily slows down your code
2. You can directly assign the value of a cell/range to another without the need to copy/paste
3. Instead of looping through each cell, you can consider the whole range
4. You can debug your code (comment the Application.ScreenUpdating = False) then press F8 to see what's happening line by line

I can't see what's the purpose of your code as it just adds all the numbers greater than zero but without any descriptions, is this a practice or you need to further have some other code ?

Try the below code see if it does what you need - I have added some comments for you

Sub aa()

Dim Lr As Long

'check if sheets exists clear data if doesn't create one
If Evaluate("isref(TEST!A1)") Then Sheets("TEST").UsedRange.Clear Else Sheets.Add.Name = "TEST"

With Sheets("Booking")
   Lr = .UsedRange.Rows.Count
   For x = 5 To 14 'loop from column 5 (E) to column 14 (N)
      Sheets("TEST").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Lr) = .Cells(2, x).Resize(Lr).Value
   Next
End With

With Sheets("TEST").Columns(1)
   .Replace 0, "", lookat:=xlWhole                  'replace all 0 values with blank
   .SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete all blank rows
End With

End Sub

Actually, this is just a part of what I need to do. Starting point so to speak. Also, I don;t see the criteria part in your code. I need that for the other part of the code. That's why I had a breakdown of criteria in my code. Also, the code works perfectly but it also includes those non-zero value that the column B has no value (subtotals and grand total).

Lastly, this is just a favor, but can you recreate my code like yours, but the criteria is still present?

Thank you

 

[mse330]

Oops, since I was working with a picture of your sheet I missed the blank column B criteria ? ... Try the revised below code which should exclude subtotals/grand total

Sub aa()

Dim Lr As Long

'check if sheets exists clear data if doesn't create one
If Evaluate("isref(TEST!A1)") Then Sheets("TEST").UsedRange.Clear Else Sheets.Add.Name = "TEST"

With Sheets("Booking")
   Lr = .UsedRange.Rows.Count
   For x = 5 To 14 'loop from column 5 (E) to column 14 (N)
      a = Evaluate(Replace("if({1},if(@="""","""",offset(@,," & x - 2 & ")))", "@", "Booking!" & .Range("B2").Resize(Lr).Address))
      Sheets("TEST").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(a)) = a
   Next
End With

With Sheets("TEST").Columns(1)
   .Replace 0, "", lookat:=xlWhole                  'replace all 0 values with blank
   .SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete all blank rows
End With

End Sub