Excel VBA count cells until a date is found - excel

I've got an amount of data copied from a table in a .pdf that when pasted into excel puts it all into one column. There are actually multiple pages each with it's own table (the data is one continuous long table split over multiple pages more accurately) and at the top of each page is a series of lines that I'm not interested in (the same unwanted data is at the top of each page). What I am interested in is re-sorting the data under the headers as it is in the table on the original .pdf document, removing the headers in the process. The data as it has been pasted into one column essentially is a list of items in plain text for x rows, followed by a list of start dates for x rows, and then a list of end dates for x rows, repeated every page.
I've figured out how to count the number of lines I don't want by getting a macro to look for the first piece of data I'm interested in ("AAAA") starting at cell (B2);
Cells(2, 2).Select
For i = 1 To 50
If ActiveCell = "AAAA" Then
Exit For
End If
ActiveCell.Offset(1, 0).Select
Next i
Cells(2, 3) = i
If i = 51 Then
Range("B3") = "Cannot find data"
End If
Which starts a search at cell (B2) looking downwards until it finds "AAAA" it then prints how many rows it has moved downwards to find it in cell (C2).
I now wish to be able to start at the cell it has just found [(B34) in this case] and count downwards until it finds the first cell containing a date.
Ultimately I'll need to then count down the same number of cells to find the associated end date and print them all in one row, continuing for the entire column of data.
If anybody could help me with being able to start at the first cell "AAAA" and then count downwards until a date is found, that would be really helpful.

My biggest challeng is to understand what you want to be true. I tryed to make a list of the things what you want.
You have a PDF that when paste in Excel it transform all the
document in one column.
There is a header in each of the Excel pages that you want to delete.
After you find a header you want to find two dates, and they have the same distance from the header.
How I would do it:
For iCounter = 1 to Cells(1048576, 1).End(xlUp).Row
If Cells(iCounter,1) = "YOUR HEADER HERE" then
For kCounter = iCounter to Cells(1048576, 1).End(xlUp).Row
If IsDate(Cells(kCounter,1)) = true then
initialDate = Cells(kCounter,1)
endDate = Cells(2*kCounter-iCounter,1)
End if
Next kCounter
End if
Next iCounter

The following piece of code starts in cell A1 and searches downward until it finds a cell containing a date value. The code only searches until it reaches the last record in the first column (to avoid searching all the way down to the bottom of the sheet if no date is found).
Sub FindFirstDate()
Dim i As Long
For i = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If IsDate(ActiveSheet.Cells(i, 1).Value) = True Then Exit For
Next i
MsgBox "The first cell with a date is " & ActiveSheet.Cells(i, 1).Address
End Sub
In this example the address of the cell with the first date in returned in a MsgBox.

Related

VB loop code to delete cell range based on another cell value

I am fairly new to code and haven't found a post covering this so any help would be great.
Basically am trying to review a large number of rows and delete a cell range in a row if a specified cell in the row does not equal a certain character or if a specified cell equals "TEXT". The furthest I have come is entire row deletion based on the specified criteria to delete.
Currently:
Dim dblrow As Double
Dblrow = 6
Do while (Cells(dblrow,1).Value <> "")
If Cells(dblrow, 23).Value <> "0" _
Or Cells(dblrow,5).Value = "TEXT" Then
Rows(dblrow).Select
Selection.Delete
Thank you

Copy a cell from one sheet to another sheet if that cell contains a particular text

I have compiled wheel data but want a VBA macro that copies any cell from sheet 1 (named: SheetSJ) that matches partial text, and then copies that cell's data into sheet 2. This is to make the data much easier to work with.
Search each row for any cells in SheetJS that contain text "Product ID", if no matches then ignore
If any cell (text) matches, copy that cell, and paste the contents to sheet 2 column B (beginning with row 2)
Search each row for any cells in SheetJS that contain text "Bolt Pattern", if no matches then ignore
If any cell (text) matches, copy that cell, and paste the contents to sheet 2 column D (beginning with row 2)
Wheel Data
As evident in the picture, the data is all over the place in each column and thus the macro cannot use any particular cell for reference. It can only match text values (which are unique).
Sub Test()
For Each Cell In Sheets(1).Range("A1:ZZ200")
If Cell.Value = "Product ID" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub
I managed to find some examples online but they copy the entire row not the individual cell.
How about this code?
I cannot use English well, but if you want, I will help you with my best.
Sub test()
For Each cell In Sheets(1).Range("A1:ZZ200")
matchrow = cell.Row
If cell.Value Like "*Product ID*" Then 'You have to use "Like" Operator if you want to use wildcard something like *,?,#...
Sheets(2).Range("B" & matchrow).Value = cell.Value
'I recommend you to use ".value" Property when deal only text, not else(like cell color, border... etc), rather than "select-copy-paste". It could be slower while hoping both sheets
ElseIf cell.Value Like "*Bolt Pattern*" Then
Sheets(2).Range("D" & matchrow).Value = cell.Value
End If
Next
End Sub
I don't think you need a macro at all. In sheet2 column B, row 2, place the following formula:
=iferror(index(SheetJS!2:2,match("*Product ID*",SheetJS!2:2,0)),"")
The iferror part just keeps the cell empty if no match is found (as opposed to giving an ugly error message). Match tells how far into row 2 the product id occurs, and index goes that far in and gets the value.
Now grab the handle at the bottom right corner of the cell, and drag it down as many rows as you have rows in the first sheet. That should bring all product IDs from Sheet JS into column B.
Similarly start in row 2 column D with
=iferror(index(SheetJS!2:2,match("*Bolt Pattern*",SheetJS!2:2,0)),"")
and drag that on down.
I'm assuming no row has more than one product id or bolt pattern, which appears to be true.
This approach does have a mild drawback, that it will leave a blank space in the sheet 2 column if the SheetJS does not have that entry in that row.

How can I prevent a merged cell, in a Do While loop, from moving my selected cell from one column to another in VBA?

I receive excel files from a bank that contains information that I need in a certain column. So I want to loop through the specific column and get the values of those cells. Lets say I select column B. I start at B1 and loop through the column cells. But once I get to a merged cell, which there are quite a lot of, the merged cell throws me off of column B when I try to move past it. I'm using Offset(1, 0) to go down the column.
'Here is a quick example of how the selected cell will move
'I'm using an index to move down 15 cells
'Merge cell A2 and B2 before running the macro
Sub test()
Dim index As Integer
index = 0
Range("B1").Select
Do While index < 15
Selection.Offset(1, 0).Select
index = index + 1
Loop
End Sub
The selection moves from B1 to B2, which is merged with A2, then continue to A3 instead of B3.
Using Select is not a best practice, but if you need it for some visual reasons, the code below would work. It gets a starting cell startingRange and each time it loops one row down from it - startingRange.Offset(rowoffset:=index).Select
Sub TestMe()
Dim index As Long
index = 0
Dim startingRange As Range
Set startingRange = Worksheets(1).Range("B1")
Do While index < 15
startingRange.Offset(rowoffset:=index).Select
Application.Wait (Now + #12:00:01 AM#)
index = index + 1
Loop
End Sub
The Application.Wait (Now + #12:00:01 AM#) is added in order to visualize the Seleced cell better.
You should do this without using Select, VBA can address any cell in your workbook without selecting it first and find out what value it contains. There are doubtless different ways of doing what you want to achieve, but this example explains how to move through a column without it deviating:
Sub test()
For Each Cell In Range("B1:B14").Cells
'Finds the MergeArea of the Cell and gets the value from the top left cell
MsgBox Cell.MergeArea.Cells(1, 1).Value
Next
End Sub
When you run the sub it'll fire off Message Boxes containing the values of the cells in column B, rows 1-14, including those that are merged.
This is probably an incomplete answer, your final answer may be a mixture of the code in this example plus the code in your original question.

If a row is empty, how do I copy/paste data from the row below it to populate the empty row?

I have a spreadsheet with numerous blank rows, and I need to extract specific data from cells below each blank row to populate the blank one. I'm just not good enough yet at VBA to figure out how to do this complex set of steps, so thank you in advance, and sorry to the developers who don't like how to do this questions.
I've broken down the steps I need.
Determine if row is empty.
If true, copy text from column A of the row below the empty row.
Paste text into column A of the empty row.
Change last three digits of text to "XXX".
Continue until end of spreadsheet.
EDIT: Cells as they currently are:
What I want them to look like:
I'm trying to do this for every set, but there may be 2, 3, 4, or more groups of rows with a blank row above them. So the VBA needs to include all of the rows in that group.
This sounds like what you want. If your numbers are numeric you'll want to convert them to text before your try to take out digits.
Sub dostuff()
For ir = 1 To 10000
If (Cells(ir, 1).value = "" And Cells(ir + 1, 1).value = "") Then _
Exit For
If (Cells(ir, 1).value = "") Then _
Cells(ir, 1).value = _
Mid(Format(Cells(ir + 1, 1).value,"00000000"),1,5) & "XXX"
Next ir
End Sub

Sort a list by groups of varying number of rows

I've imported the results of a broken link search in to Excel and I now need to sort the results based on the error code. I can't get my head around how to do this because the error code is in the row below the URL and not in a column next to it. Also, some URLs take up more than one row.
Here is a screenshot of part of the spreadsheet:
How would I go about grouping all results with error 404 together?
Below you'll find a VBA code that do what you need. As I don't have the original sheet I create an excel and put some random data. Works fine for me.
Sub test()
Dim row, rowDest, rowAux As Integer
Dim source As Worksheet
Dim dest As Worksheet
'Replace here by the name of the worksheet that contains the data
Set source = Worksheets("Sheet1")
'This is the sheet where the modified data will be placed
Set dest = Worksheets("Sheet2")
'Start row (source sheet)
row = 1
'Start row (dest sheet)
rowDest = 1
'This is an auxiliary variable used to fill the error code column
rowAux = 0
'Go to the last line (column 1) of your source sheet and write the string !q
'This will be used as a flag to know where your data finish
While (source.Cells(row, 1).Value <> "!q")
If (InStr(source.Cells(row, 1).Value, "http") > 0) Then
dest.Cells(rowDest, 1).Value = source.Cells(row, 1).Value
If (rowAux = 0) Then rowAux = rowDest
rowDest = rowDest + 1
ElseIf (InStr(source.Cells(row, 1).Value, "error code") > 0) Then
While (dest.Cells(rowAux, 1).Value <> "")
dest.Cells(rowAux, 2).Value = source.Cells(row, 1).Value
rowAux = rowAux + 1
Wend
rowAux = 0
End If
row = row + 1
Wend
End Sub
My dataset and results:
Source sheet:
Dest sheet:
Insert a column to the left of A and fill in with a sequence of numbers (1, 2, 3, ...). Now sort by column B. Select all the error code entries and drag them to column c (or some other empty column). Resort the sheet by the sequence of numbers in column A. Now with everything ordered and the error codes is a separate column (C), you can right-click on C1, and select shift cells up. Column A can be deleted, and you can sort by the URL's (although it looks like you clean up the text a bit).
This is going to be difficult to do unless you can get the error code in the same row as the URL. However, you can still do it by using the SEARCH function on the error code. This will find the 404 error, but it won't give you the URL in the cell beneath it. Therefore, you need a function that checks to see if the cell beneath it's cell has found a 404 code. Then you can filter on the "true" values and get two rows.
Create a new column in A, and use the function below.
=IF(ISNUMBER(SEARCH("404",B1)),1,IF(A2=1,2,0))
Filter down on 1 and 2 values.
Solution based on http://office.microsoft.com/en-us/excel-help/check-if-a-cell-contains-text-HP003056106.aspx and the function:
=IF(ISNUMBER(SEARCH("v",A2)),"OK", "Not OK")
Subject to some constraints (but they are not in your Q!) this formula in an inserted ColumnA may serve:
=INDEX(C1:C3,MATCH("*error code:*",C1:C3,0))
along with =ROW() in an inserted ColumnB (though could be elsewhere) and both copied down at the same time.
The formulae should be converted to values (copy ColumnsA:B, Paste Special..., Values over the top) and sorting be based on ColumnA then ColumnB. The rows blank in ColumnC may be deleted, as also those with error codes in that column.

Resources