VBA Insert rows at certain point in data - vba

I have this pivot table I am inserting above my data. The data can be different lengths and so the pivot table and be different lengths. So what I do is put the data a little ways down on the sheet starting at say maybe row 30. Then I insert my pivot table up top. What I do next is I then have some code to delete all of the blank rows in between my data and the pivot table.
sub foo()
dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A1:Z50")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
This code will delete all of the blank rows and seems to work correctly. Since that puts everything together, what I want to do then is just put 2 blank rows in between my pivot table and my data but I don't know how to figure out where my pivot table ends or where my data begins.
So I want it to look like that ^^^^ , but right now Row 7 and 8 are not there and my data is pushed up onto my pivot table. Any help is appreciated please!
I was thinking someone like using Rows.Count + 1 or something to find where the pivot table ends. But I don't know how it would determine that since there is data in the row right after. SO maybe I need to find when there is data starting in say Column A then Insert the rows right before that. Thank you in advance for the help!

Try something along those lines:
Public Sub Answer()
Dim dataTopRowIndex As Integer
Dim ptBottomRowIndex As Integer
With ActiveSheet 'Note: use your worksheet's CodeName here instead, e.g. With Sheet1 (Active[anything], Activate, Select, Selection: evil).
dataTopRowIndex = .Cells(1, 1).End(xlDown).Row
With .PivotTables("PivotTable1").TableRange1 'Replace PivotTable1 by your PT's name.
ptBottomRowIndex = .Row + .Rows.Count - 1
End With
If (dataTopRowIndex - ptBottomRowIndex - 1) > 2 Then
.Range(.Rows(ptBottomRowIndex + 1), .Rows(dataTopRowIndex - 3)).EntireRow.Delete
End If
End With
End Sub

Related

How can I delete all but the last two columns in an excel sheet

I have a spreadsheet that displays the file paths to ~ 13000 files in my vault. Each row may have a different number of columns. I am really only interested in the last two columns, the folder its in and the name of the file. It is far to many rows to do manually. I need a way to either delete all but the last two columns in every row or sort it by the number of columns. I am not much of a programmer, so any help will be much appreciated.
Assuming you meant VBA not VB.NET (Please update your tags if that's the case)
This will put the last two columns (that aren't blank) into column A & B. So you can either write the code to insert the two columns or do it manually, same with deleting all the columns once the code runs.
Public Sub Test()
'Insert 2 columns: A&B
Dim LastCol As Integer
For CurRow = 2 To Sheet1.UsedRange.Rows.Count + 1
LastCol = getLastColumn(CurRow)
If LastCol > 2 Then
Sheet1.Cells(CurRow, 1) = Sheet1.Cells(CurRow, LastCol - 1)
Sheet1.Cells(CurRow, 2) = Sheet1.Cells(CurRow, LastCol)
End If
Next
'Delete All columns except A&B
End Sub
Private Function getLastColumn(ByVal CurrentRow As Integer) As Integer
getLastColumn = -1
For ColCounter = Sheet1.UsedRange.Columns.Count + 1 To 1 Step -1
If Sheet1.Cells(CurrentRow, ColCounter) <> "" Then
getLastColumn = ColCounter
Exit For
End If
Next
End Function
This seems to be more a question concerning how to use excel than vb.net, but I will try to answer it anyways:
Just click on the column headers and drag the mouse to the select all columns you want to delete, then right click on any of the selected columns and select "delete columns" from the appearing context menu.

Delete Table Rows

I have a Table in my Excel. The table is called Table1.
I want to delete the entire row except 1st row of the table which it can be done manually like select the row then delete table row, but I couldn't imagine if the row is reaching more than a million records. I tried the following code:
Sheet3.Range("A20","E500000").Delete 2
But the code above is error. The error said:
This won't work because it would move cells in a table on your worksheet.
Does anyone have a same problem with me? Suggestion please.
Try below if you only have one Table object in your sheet.
Dim lo As ListObject
With Sheet3 '/* sheet code name */
Set lo = .ListObjects(1)
On Error Resume Next
lo.DataBodyRange.Delete xlUp
On Error GoTo 0
End With
If not, you can explicitly identify your table like:
Set lo = .ListObjects("Table1")
I suppose you want to delete all the rows except the header, if so, you can use DataBodyRange like this:
ActiveSheet.ListObjects("Table1").DataBodyRange.Delete
so the second row of the table start from cell A20?
if so, you just want to delete row till the last cell, then the code:
Sub dr()
Dim a As Integer
a = ActiveSheet.UsedRange.Rows.Count
Range(Range("A20"), Range("A" & a)).EntireRow.Delete
End Sub
Select the 2nd row. Press Shift+ctrl+down. This will select all the records except the header.
Right click and select delete.
Since #Haminteu want to keep the header and first row of data, I provide the solution as below.
With Range("Table1")
.Offset(1).Resize(.Rows.Count - 1).Delete 2
End With

How to shrink the data from multiple columns into one column

hopefully someone will be able to help me. I need to write a query, which would shrink the data from multiple columns (in my case from columns A:H) into one column.
The original file looks like this:
I need to shrink the data one by one by rows. I mean, the query has to check the first row and take the data (name), and put it into "a new column" then check the second column and do the same, and continue like this one by one. The table has 170 rows.
I found a query that is shrinking the data from multiple columns into one column but in another order than I need. The query is taking as first all data from a column A and putting it into "a new column", then taking all data from a column B and putting it into "a new column" under the data from the previous column (column A).
This is the query I tried to apply:
Please could somebody help me with it? I have to admit that I have not use UBound and LBound functions and I am getting pretty lost here. :(
I will be thankful for any advise how to adjust this query.
Many thanks in advance! :)
Try this. I'm first setting your range to an array. I then loop through the array and 'slice' each row using Application.Index. It then Joins all the content in that row together before Trimming the whitespace left over from either end. This leaves me with the one value in my results array (tmp). The code then clears your source data before leaving all your data in one column.
Sub CombineColumns()
Dim rng As Range
Dim tmp As Variant, vaCells As Variant
Dim i As Long
Set rng = Sheets("DATA").Range("A2:H200")
vaCells = rng.Value2
ReDim tmp(LBound(vaCells) To UBound(vaCells))
For i = LBound(tmp) To UBound(tmp)
tmp(i) = Trim(Join(Application.Index(vaCells, i, 0)))
Next i
With rng
.ClearContents
.Cells(1).Resize(UBound(tmp)).Value2 = Application.Transpose(tmp)
End With
End Sub
LBound returns the lowest position in the array (usually 0 or 1) and UBound returns the highest
I think something like this
for i = 1 to 170
for y = 1 to 8
if worksheets("trainers").cells(i,y).value <> "" then
worksheets("output").cells(i,1).value = worksheets("trainers").cells(i,y).value
exit for
end if
next y
next i
or on same sheet
For i = 1 To 170
Z = 0
For y = 1 To 8
If Cells(i, y).Value = "" Then
Cells(i, y).Delete Shift:=xlToLeft
Z = Z + 1
If Z <= 8 Then y = y - 1
End If
Next y
Next i

VBA - merge set number of rows in first column

I have seen some VBA examples on here allowing one to merge set numbers of cells, but none exactly as I need it.
What I would like to do is go down the entire column A:A and merge every four rows, starting with cell A4. I know this involves changing the reference cell but I'm not skilled enough with the language to know how to do this without screwing up the cycle.
Here is an example of the data I would like to format. Thanks in advance for any and all help with this.
Simply set Count to the number of merged cells that you want and run the MergeColA.
Sub MergeColA()
Dim Count As Integer
Count = 10
MergeCells (Count)
End Sub
Sub MergeCells(Count As Integer)
For i = 4 To 4 * count Step (4)
Dim r As Range
Set r = Range("A" & i, "A" & i + 3)
r.Merge
Next i
End Sub

Excel: Copy-paste rows in between sheets depending on multiple criteria

Thank you for the comments so far, it has helped me formulate my question better/differently.
I have two sheets, Sheet1 and Sheet2.
Sheet1 contains ~100,000 rows with 5 columns and Sheet2 should contain a subgroup of Sheet1, depending if the rows in Sheet1 contain certain values in certain columns.
This is the code I have so far. Somehow the VBA doesn't give me any error, but the code also doesn't run, which makes it difficult to find a possible solution. Anyone any ideas?
Sub CopyRows()
Dim r As Integer
Dim cell As Range
r = 2
For Each cell In Selection
If Application.WorksheetFunction.IsNA(Sheets("Sheet1").Cells(r, 1)) = False Then
If Sheets("Sheet1").Cells(r, 3) = "Product1" or "Product2" Then
If Sheets("Sheet1").Cells(r, 5) = "2011" or "2012" Then
If Sheets("Sheet1").Cells(r, 4) > 0 Then
cell.EntireRow.Copy Destination:=activesheet.Rows(r)
r = r + 1
End If
End If
End If
End If
Next cell
End Sub
For such consolidations my first bet would be a Pivot table; in your case
Company & City at the vertical
product at the horizontal (if not too many)
count or sum of value inside
plus eventually a filter to exclude empty key fields.
If you arrange your sheet1 so that there is only one header line in row 1, you can select entire columns (say $A:$D) as pivot table input range, and any additional rows will be included in the Pivot upon refresh.
Of course, the Pivot table can be sorted, filtered, subtotaled etc. etc.