Make a loop (XL XP SP-1)

Topic

New Reply

Hello,

I’ve attached a small macro as a text file. There is a definite pattern that could be refined into a do loop and I’m trying to figure it out. Also, I’d like it to stop when if finds 4 blank cells in a row (which means there is no more data, e.g.; A200:A204).

Any help would be greatly appreciated.

Reply | Quote

Replies

1) What does the code for D2:E2 do in there? It doesn’t fit the pattern.
2) A200:A204 consists of 5 cells, not 4.

Reply | Quote

Quite right, Hans. I always forget that Zed is a number .

As for D2:E2, you can ignore. This is part of another (one-time) sequence. The loop begins when the pattern develops.

Thank you.

Reply | Quote

Does this do what you want?

Dim i As Long
Dim n As Long
n = Range("A65536").End(xlUp).Row
For i = (n 3) * 3 To 3 Step -3
Range("A" & i).Cut Destination:=Range("B" & (i - 1))
Rows(i & ":" & (i + 1)).Delete Shift:=xlUp
Next i

Test on a copy of your workbook!

Reply | Quote

Hans,

The last line appears in red and I get a message when I run it that it has a syntax error.

Reply | Quote

Next i ???

Reply | Quote

Hans,

Yeah. Next i should have been on the next line. When I got it in the email, Next i was on the same line right after the last line that reads: Rows…..Delete Shift:=xlUp

Anyway, I put it on the next line and now it runs, however, I’m losing all of the data.

Could you explain the “For i ” instruction and the Rows (i & “:” &(i+1).Delete Shift:=xlUp

If this doesn’t work, I’ll send you the whole macro and small spreadsheet as a last resort.

Reply | Quote

Hans,

After reviewing my methodolgy, I found that I began in the wrong place. The loop is as follows:

Range(“A4”).Select
Selection.Cut Destination:=Range(“B3”)
Rows(“4:5”).Select
Selection.Delete Shift:=xlUp
Range(“A5”).Select
Selection.Cut Destination:=Range(“B4”)
Rows(“5:6”).Select
Selection.Delete Shift:=xlUp
Range(“A6”).Select
Selection.Cut Destination:=Range(“B5”)
Range(“B5”).Select

Basically what I am doing is moving contents of a cell to the right (-1) and above (-1) the current cell and then deleting 2 rows where data was, but is now blank.

Reply | Quote

Could you post a small sample workbook?

Reply | Quote

Hans,

Thanks for taking the time. As you can see from my post above, I show the code of the loop. Attached is a sample of the spreadsheet. Basically, the advertiser needs to be on the same row as the Market, copy the date down, and then put the money and salesperson on the same line as the other data for the record.

Reply | Quote

Hans, Sorry. It’s late and I must be having several brain farts. Here’s the file.

Reply | Quote

I don’t understand the structure.

Reply | Quote

Hans and Steve, There is a structure: Market and Advertiser are in the same column, with advertiser under market. I want to create 2 new columns: one for the advertiser (moving it from the column on the left and bringing it up one row) and another column for the date. Now the money and salesperson need to come up to put all the fields in the same row. After that, I need to delete the blank rows.

I appreciate your trying to sort out my thinking process and willingness to help me. I’m sorry that I’m not being as clear as I need to be. Any guidance would be appreciated.

Reply | Quote

Advertiser and Date already exist in your sample data. Do you want to create 2 additional columns?

Based on the sample data, you provided, what do you want to output to look like? Does it match what my macro does?

Steve

Reply | Quote

Steve,

I attached a file that depicts a “before” and “after” to help demonstrate what I’m trying to accomplish. Sorry for the confusion. I’m working on deciphering (for my own learning) and putting your code into my personal.xls file to run.

Reply | Quote

how about this? [Your test range did not include one the col C being “wrapped” as it did in your original, but I assumed this would still be an issue and worked awith it]

Steve

Option Explicit
Sub ExtractData2()
   Dim wksSource As Worksheet
   Dim wksDest As Worksheet
   Dim lRows As Long
   Dim lSource As Long
   Dim lDest As Long
   Dim i As Integer
   Dim sDate As String
   Dim sFormat As String
   
   Set wksSource = Worksheets("Test")
   sDate = wksSource.Range("B1")
   sFormat = "$#,##0.00_);[Red]($#,##0.00)"
   lRows = wksSource.Range("B65536").End(xlUp).Row
   
   Set wksDest = Worksheets.Add

   With wksDest
      .Range("A1") = wksSource.Cells(2, 1).Value
      .Range("B1") = "Advertiser"
      .Range("C1") = "Date"
      .Range("D1") = wksSource.Cells(2, 2).Value
      .Range("E1") = wksSource.Cells(2, 3).Value
      With .Range("A1:E1")
         .Font.Bold = True
         .HorizontalAlignment = xlCenter
      End With
   End With
   lDest = 1
   With wksSource
      For lSource = 3 To lRows
         If .Cells(lSource, 1)  "" And _
            .Cells(lSource, 2)  "" Then
            
            lDest = lDest + 1
            wksDest.Cells(lDest, 1) = .Cells(lSource - 1, 1)
            wksDest.Cells(lDest, 2) = .Cells(lSource, 1)
            wksDest.Cells(lDest, 3) = sDate
            wksDest.Cells(lDest, 4) = .Cells(lSource, 2)
            If .Cells(lSource + 1, 2) = "" Then
               wksDest.Cells(lDest, 5) = .Cells(lSource, 3) & _
                     " " & .Cells(lSource + 1, 3)
            Else
               wksDest.Cells(lDest, 5) = .Cells(lSource, 3)
            End If
         End If
      Next
   End With
   wksDest.Columns.EntireColumn.AutoFit
   wksDest.Columns(4).NumberFormat = sFormat
   Set wksSource = Nothing
   Set wksDest = Nothing
End Sub

Reply | Quote

Steve, Hats off to you, my man. This worked like a charm. It looks quite complicated and I will try to understand it.

Thank you all for your patience and TGIF, as well.

Pass along the thanks to Hans also. Being a trainer and in technology, I know it’s frustrating when a user can’t communicate properly.

Reply | Quote

You don’t haqve regular patterns in the data. It may have to be done “manually” with some formulas and filtering instead of a macro.

Steve

Reply | Quote

Is this what you are after??

Option Explicit
Sub ExtractData()
   Dim wksSource As Worksheet
   Dim wksDest As Worksheet
   Dim lRows As Long
   Dim lSource As Long
   Dim lDest As Long
   Dim i As Integer
   Dim sDate As String
   Dim sFormat As String
   
   Set wksSource = Worksheets("Test")
   sDate = "1/31/2005 to 02/06/05"
   sFormat = "$#,##0.00_);[Red]($#,##0.00)"
   lRows = wksSource.Range("D65536").End(xlUp).Row
   
   lDest = 1
   Set wksDest = Worksheets.Add

   For i = 1 To 5
      With wksDest.Cells(lDest, i)
         .Value = wksSource.Cells(lDest, i).Value
         .Font.Bold = True
      End With
   Next
   With wksSource
      For lSource = 2 To lRows
         If .Cells(lSource, 2) = "" And _
            (.Cells(lSource, 4) = "" Or _
            .Cells(lSource, 5) = "") Then
            'Skip this row it should be blank
         Else
            lDest = lDest + 1
            If .Cells(lSource, 2) = "" Then
               wksDest.Cells(lDest, 1) = .Cells(lSource - 1, 1)
               wksDest.Cells(lDest, 2) = .Cells(lSource, 1)
            Else
               wksDest.Cells(lDest, 1) = .Cells(lSource, 1)
               wksDest.Cells(lDest, 2) = .Cells(lSource, 2)
            End If
               wksDest.Cells(lDest, 3) = sDate
               wksDest.Cells(lDest, 4) = .Cells(lSource, 4)
               If .Cells(lSource + 1, 4) = "" And _
                  .Cells(lSource + 1, 5)  "" Then
                  wksDest.Cells(lDest, 5) = .Cells(lSource, 5) & _
                     " " & .Cells(lSource + 1, 5)
               Else
                  wksDest.Cells(lDest, 5) = .Cells(lSource, 5)
               End If
         End If
      Next
   End With
   wksDest.Columns.EntireColumn.AutoFit
   wksDest.Columns(4).NumberFormat = sFormat
   Set wksSource = Nothing
   Set wksDest = Nothing
End Sub

It creates a new sheet with a new copy of the data, reformatted. After checking you can delete the original.

Steve

Reply | Quote