Convert bad SAP report into nice table

[Krisz06]

Hello everyone,
I need some help. I'm trying to create a macro which converts a (really bad) SAP report to a good table with only the necessary info.
The table is about vendors. Till the last step everything works correctly.
But there is a little problem, the report contains the existing data from the system and in some case there are an extra line ("street 2" field). That ruins the macro logic as the last step says "ActiveCell.Offset(1, -10).Range("A1:A71").Select"
In some case it should be 72 instead of 71.

Here is the code:

Sub XYZ ()


Range("C9").Select


Do
If Selection.Value = "" Then Exit Do


ActiveCell.Offset(6, 0).Range("A1").Select
Selection.Copy
ActiveCell.Offset(-6, 1).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(6, 7).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-6, -6).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(13, -2).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-13, 3).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(13, 5).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-13, -4).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(17, -4).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-17, 5).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(26, 3).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-26, -2).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(42, -6).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-42, 7).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(11, 1).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-11, 0).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(64, -8).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-64, 9).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(65, -9).Range("A1").Select
Selection.Cut
ActiveCell.Offset(-65, 10).Range("A1").Select
ActiveSheet.Paste


ActiveCell.Offset(1, -10).Range("A1:A71").Select
Selection.EntireRow.Delete
ActiveCell.Select


Loop


End Sub

I have been thinking on 2 possible solution:
Somehow using "Selection.End(xlDown).Select".. with this a little problem that there is an empty cell in that columnThe other option is to remove every line which contain "Street2" in the column B.. that would make all separate vendor has only 71 line.




Can someone please help?
Thank you!

 

[Fluff]

Try

Sub XYZ()
'Krisz06
    
    Dim Srng As Range
    Dim Erng As Range


    Range("C9").Select
    
    Do Until ActiveCell.Value = ""
    
        With ActiveCell
            .Offset(6).Copy .Offset(, 1)
            .Offset(6, 8).Cut .Offset(, 2)
            .Offset(13).Cut .Offset(, 3)
            .Offset(13, 8).Cut .Offset(, 4)
            .Offset(17).Cut .Offset(, 5)
            .Offset(26, 8).Cut .Offset(, 6)
            .Offset(42).Cut .Offset(, 7)
            .Offset(11, 8).Cut .Offset(, 8)
            .Offset(64).Cut .Offset(, 9)
            .Offset(65).Cut .Offset(, 10)
            Set Srng = ActiveCell.Offset(1)
            On Error Resume Next
            Set Erng = Columns("B:B").Find(What:="memo", After:=[COLOR=#ff0000]Range("B9")[/COLOR], LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False).Offset(1)
            On Error GoTo 0
            If Erng Is Nothing Then
                Set Erng = Range("B" & Rows.Count).End(xlUp)
            End If
            Range(Srng, Erng).EntireRow.Delete
            .Offset(1).Select
            Set Srng = Nothing
            Set Erng = Nothing
        End With
    Loop

End Sub

I've changed the part in red to reflect the column change

 

[Krisz06]

Thank you Fluff,
It is working correctly.
Somehow at the end of the table there were a little problem, some vendor were without the empty cell. So manually I added it and the loop went till the last line how it should be. Hurray!

But just one last thing I'm thinking on.
Would it be possible to use the cell names instead of the offsets? In some case the offsets are not correct as for example the IBAN field sometimes not on the same place.
Somehow in the same way as finding cell Memo in column B, if it would be "search field IBAN in column B, and then copy the same row's column C"?
I guess this would make the macro slowlier, but it is not a problem.

You think it is possible to use the cell names instead of offset?
Thank you!

 

[Fluff]

Yes that's possible.
What are the values to find & what is the row offset they relate to?

 

[Krisz06]

Hi,


One of them is the 7th line in your code
" .Offset(42).Cut .Offset(, 7) "
This would be for example searching column B's "IBAN" cell, and then copying the next cell (in column C) to the original activecell Offset(,7)


If this would work, the other similar cases I could manage (hopefully) alone by the same logic


Thank you!

 

[Fluff]

How about

Sub XYZ()
'Krisz06
    
    Dim Srng As Range
    Dim Erng As Range
    [COLOR=#ff0000]Dim IBAN As Range
[/COLOR]
Application.ScreenUpdating = False

    Range("C9").Select
    
    Do Until ActiveCell.Value = ""
    
        With ActiveCell
            .Offset(6).Copy .Offset(, 1)
            .Offset(6, 8).Copy .Offset(, 2)
            .Offset(13).Copy .Offset(, 3)
            .Offset(13, 8).Copy .Offset(, 4)
            .Offset(17).Copy .Offset(, 5)
            .Offset(26, 8).Copy .Offset(, 6)
             [COLOR=#ff0000]Set IBAN = Columns("B:B").Find(What:="IBAN", After:=Range("B9"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If IBAN Is Nothing Then
                MsgBox "IBAN not found"
                Exit Sub
            End If[/COLOR]
            .Offset([COLOR=#ff0000]IBAN.Row - 9[/COLOR]).Copy .Offset(, 7)
            .Offset(11, 8).Copy .Offset(, 8)
            .Offset(64).Copy .Offset(, 9)
            .Offset(65).Copy .Offset(, 10)
            Set Srng = ActiveCell.Offset(1)
            Set Erng = Columns("B:B").Find(What:="memo", After:=Range("B9"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Erng Is Nothing Then
                Set Erng = Range("B" & Rows.Count).End(xlUp)
            Else
                Set Erng = Erng.Offset(1)
            End If
            Range(Srng, Erng).EntireRow.Delete
            .Offset(1).Select
            [COLOR=#ff0000]Set IBAN = Nothing[/COLOR]
            Set Srng = Nothing
            Set Erng = Nothing
        End With
    Loop

End Sub

Highlighted in red the changes.

 

[Krisz06]

Thank you Fluff!!!
This is perfect now!
A little editing needed " .Offset(IBAN.Row - 9).Copy .Offset(, 7) " needed to be changed to " .Offset(IBAN.Row - ActiveCell.Row).Copy .Offset(, 7) "and after this all of the IBANs got to the correct place.
I will need to do the same with some other fields, but it's Friday, so it was enough success, Monday will do the rest of the changes

Thanks again! Maybe on Monday I will post some update on this topic, or asking some other tricks to clear up the report to look even nicer :D
Have a nice weekend!

 

[Fluff]

Glad to help & thanks for the feedback.
Have a good weekend yourself

 

[Krisz06]

Hi Fluff,

Thank you for your help last week. I have updated the code to search all of the values with the Range.Find method so it will be correct in any case. The macro could go till the last line, so it works perfectly. From here I can modify it for any kind of similar reports, hurray!


But I just have some other questions, just to learn from them )

I'm checking the code

Set IBAN = [COLOR=#ff0000]Columns("B:B")[/COLOR].Find(What:="IBAN", After:=[COLOR=#00ffff]Range("B9"[/COLOR]), LookIn:=xlFormulas, _                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
             On Error Resume Next
                .Offset(IBAN.Row - ActiveCell.Row).Copy .Offset(, 7)

So if I understand correctly, this search finding the next cell in B column which have IBAN in it...
Luckily the situation is not this, but let's say for one of my records the IBAN field is missing, in this case by this code it would add the next record's IBAN. Then it would delete the usual rows and the macro would go back to it's original findings and run as usual.
Are there any possibility to add this to the code? For example the range would be "B.ActiveCell.Row : B.ActivicellRow+80" or something like this?

And maybe the same with the other range as well? Later in the loop the range should start not B9 but B.Activecell
I always have troubles with what to put into the brackets in situations like this :/

 

[Fluff]

You can change

Columns("B:B")

to

ActiveCell.Offset(, -1).Resize(80)

But a better way would be to get rid of the ActiveCell like this

Sub XYZ()
'Krisz06
    
    Dim Srng As Range
    Dim Erng As Range
    Dim IBAN As Range
    Dim Rw As Long

Application.ScreenUpdating = False

    Rw = 9
    Do Until Range("C" & Rw).Value = ""
    
        With Range("C" & Rw)
            .Offset(6).Copy .Offset(, 1)
            .Offset(6, 8).Copy .Offset(, 2)
            .Offset(13).Copy .Offset(, 3)
            .Offset(13, 8).Copy .Offset(, 4)
            .Offset(17).Copy .Offset(, 5)
            .Offset(26, 8).Copy .Offset(, 6)
             Set IBAN = Range("B" & Rw).Resize(80).Find(What:="IBAN", After:=Range("B9"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If IBAN Is Nothing Then
                MsgBox "IBAN not found"
                Exit Sub
            End If
            .Offset(IBAN.Row - Rw).Copy .Offset(, 7)
            .Offset(11, 8).Copy .Offset(, 8)
            .Offset(64).Copy .Offset(, 9)
            .Offset(65).Copy .Offset(, 10)
            Set Srng = Range("C" & Rw + 1)
            Set Erng = Range("B" & Rw).Resize(80).Find(What:="memo", After:=Range("B9"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Erng Is Nothing Then
                Set Erng = Range("B" & Rows.Count).End(xlUp)
            Else
                Set Erng = Erng.Offset(1)
            End If
            Range(Srng, Erng).EntireRow.Delete
            Rw = Rw + 1
            Set IBAN = Nothing
            Set Srng = Nothing
            Set Erng = Nothing
        End With
    Loop

End Sub

 

[Krisz06]

Dear Fluff,
Thank you, it is just working perfectly! Whole report is perfect now!
Have a nice day!