Transpose Rows to Columns VBA Code and delete specific account numbers

I am back I need one more help to complete my task. I want Transpose Rows to Columns and need to delete two account numbers (7000 and 3000) details from the data. I have attached a sample of my data set before(sheet1) and after(sheet2) and a screen shot too. my data set is more than 35 pages so, need a loop too. the address data is random. address data(C column) has various number of lines (2,3 or4) . After one row of data I have a 6 row gap to the next data. The data was converted from .txt file. please help ......

Attachment 194690Attachment 194691

Any help is appreciated and thank you for reading my post.Please help me!!!

Please ...any help

Atleast anyone can help on Transpose the Rows to Columns VBA Code ... please ...

A bit Rube Goldbergish, but this is the closest I could get. Hope it helps.

Sub cowboys()
Dim lr As Long
Dim rcell As Range
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set ws = ActiveSheet

Sheets("Sheet2").Cells.Clear

ws.Activate
For Each rcell In ws.Range("A2:A100")

    If rcell.Value <> "" Then
    
        Select Case rcell.Offset(2, 2).Value
        
            Case Is = ""
            
            
                rcell.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(3)(2)
                rcell.Offset(, 1).Copy Sheets("Sheet2").Range("B" & Rows.Count).End(3)(2)
                rcell.Offset(, 2).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(3)(2)
                rcell.Offset(1, 2).Copy Sheets("Sheet2").Range("G" & Rows.Count).End(3)(2)
                

            Case Else
            
                rcell.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(3)(2)
                rcell.Offset(, 1).Copy Sheets("Sheet2").Range("B" & Rows.Count).End(3)(2)
                rcell.Offset(, 2).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(3)(2)
                rcell.Offset(2, 2).Copy Sheets("Sheet2").Range("G" & Rows.Count).End(3)(2)
                rcell.Offset(1, 2).Copy Sheets("Sheet2").Range("F" & Rows.Count).End(3)(2)
            
        End Select
     
    End If
Sheets("Sheet2").Activate
lr = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet2").Range("A2:i" & lr).Replace what:="", Replacement:=" ", Lookat:=xlWhole
ws.Activate
Next rcell

Sheets("Sheet2").Activate
                
lr = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
                
Range("A1").Value = "Company name"
Range("B1").Value = "ACC"
Range("C1").Value = "Address"
Range("D1").Value = "Address1"
Range("E1").Value = "Address2"
Range("F1").Value = "Address3"
Range("G1").Value = "City"
Range("H1").Value = "ST"
Range("I1").Value = "Zip Code"

Range("A1:I1").Font.Bold = True
                
For Each rcell In Range("B2:B1000")

    If rcell.Value = 7000 Then
    
        rcell.EntireRow.Delete SHIFT:=xlUp
        
    End If
    
    
Next rcell
                
    Range("C2:C100").Select
    Selection.TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    ActiveWindow.SmallScroll ToRight:=4
    Range("G2:G100").Select
    Selection.TextToColumns Destination:=Range("G2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("H2:H100").Select
    Selection.TextToColumns Destination:=Range("H2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    Range("H2:H100").Delete SHIFT:=xlToLeft
    Columns("A:A").ColumnWidth = 39.43
    Columns("B:B").ColumnWidth = 6.86
    Columns("C:C").ColumnWidth = 43
    Columns("D:G").ColumnWidth = 15.71
    Columns("H:H").ColumnWidth = 5
    Columns("I:I").ColumnWidth = 8.14
    
For Each rcell In Range("B2:B1000")

    If rcell.Value = 3000 Then
    
        rcell.EntireRow.Delete SHIFT:=xlUp
        
    End If
        
Next rcell

Rows("2:2").Delete SHIFT:=xlUp

Application.ScreenUpdating = True
Application.DisplayAlerts = True
      
End Sub

Thanks! but ......