I have an excel sheet with headers in row 1 and values for each of those columns from -2 to 2 in the subsequent rows. I would like to delete a column (including the header) if each row contains the value 0.
Example: I have three columns A, B, and C and 1500 rows. The header for each of these rows are Patient 1, Patient 2, and Patient 3. Patient 3 contains 0 in each of the 1499 rows and I want to have a final spreadsheet with just Patient 1 and Patient 2.
Thanks for your time.
You could try something like this:
Sub RemoveZeroBasedColumns()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")
Dim iLastCol As Integer
Dim iLastRow As Long
Dim iC As Integer
With oWS
iLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
For iC = 1 To iLastCol
If WorksheetFunction.CountIf(Range(Chr(64 + iC) & ":" & Chr(64 + iC)), 0) = iLastRow Then
.Columns(iC).Delete shift:=xlShiftToLeft
iLastCol = iLastCol - 1
End If
Next
End With
End Sub
Related
I have a data export that pulls customer info with one row for each parent, and 8 port columns (port1, port2, etc... to port8). I need to transpose the port columns into a unique record for each port that retains the customer info in the parent. The source sheet can have 100+ records, the destination sheet will have a maximum of x8 as many records as source sheet because no row has more than 8 ports. I am struggling with how to proceed from here. My idea was to loop through each SourceData row, build an array for each row that contains all ports field values, transpose this into a new sheet and paste, and continue this until last row. The struggle is the paste destination must paste in gaps of 8, then the sheet must be filtered so blanks are not present, and then vlookup against the remaining data.
Source Format
Desired Format
Sub test3()
Dim wb As Workbook
Dim sourceData As Worksheet
Dim outputData As Worksheet
Set wb = Workbooks("Book1")
Set sourceData = Worksheets("Sheet1")
Set outputData = Worksheets("Sheet2")
Dim Rng As Range
Dim ctr As Long
ctr = 2
Dim iCol As Long, lCol As Long, lRow As Long 'iteration column, last column
Const fCol = 15 'first column
With sourceData
lCol = 22 'last used column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row 'find last used row
For i = 2 To lRow
For iCol = fCol To lCol
Set Rng = Cells(i, iCol)
outputData.Cells(ctr, fCol).Value = Rng
ctr = ctr + 1
Next iCol
Next i
End With
End Sub
Edit 2: updated to include extra rows as output.
Lightly tested...
Sub test3()
Dim wsSrc As Worksheet, srcData, outData, r As Long
Dim c As Long, rOut As Long, p As Long, prt
'get input data as array
Set wsSrc = Worksheets("Sheet1")
srcData = wsSrc.Range("A2:W" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row).Value
'size output array to max potential size (+ added some space for pepwave/remote cases)
ReDim outData(1 To 10 * UBound(srcData, 1), 1 To 16)
For r = 1 To UBound(srcData, 1) 'loop input data rows
For p = 1 To 8 'loop ports
prt = srcData(r, 14 + p)
If Len(prt) > 0 Then 'if any port value...
rOut = rOut + 1 'add output row
For c = 1 To 14 'populate common columns
outData(rOut, c) = srcData(r, c)
Next c
outData(rOut, 15) = prt 'add port value
outData(rOut, 16) = srcData(r, 23) 'col W value
End If
Next p
'test to see if we're adding additional rows...
If InStr(1, srcData(r, 6), "pepwave", vbTextCompare) > 0 Then
rOut = rOut + 1
'populate pepwave row from srcdata (r,x)
End If
If InStr(1, srcData(r, 6), "data remote", vbTextCompare) > 0 Then
rOut = rOut + 1
'populate data remote row from srcdata (r,x)
End If
'done testing for additional rows
Next r
If rOut > 0 Then
Worksheets("Sheet2").Range("A2").Resize(rOut, UBound(outData, 2)).Value = outData
End If
End Sub
I am working on a project where I need to populate the column headings with incremental values (increased by 1) until the Last Column.
The code is working OK but the value in the column headings is NOT increased by 1. It is just taking the original value and place it over all columns.
Could you help me?
My code so far:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = Cells(4, i).Value + 1
i = i + 1
Loop
End Sub
I find your code a little strange, but probably i am missing something. Anyway this one should work:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
Dim IntCounter01 As Integer '<<<<<<ADDED LINE (1 of 3)
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
IntCounter01 = 1 '<<<<<<ADDED LINE (2 of 3)
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = IntCounter01
i = i + 1
IntCounter01 = IntCounter01 + 1 '<<<<<<ADDED LINE (3 of 3)
Loop
End Sub
I took your code and added 3 lines. You could also use a For-Next cycle instead of using a Do-While-Loop cycle since you already know your maximal value. Something like:
For i = i To LastColumn - 1
Cells(4, i).Value = IntCounter01
IntCounter01 = IntCounter01 + 1
Next
You could also use a formula to cover your range instead of picking each cell one by one. Like this:
Sub LastColumn_PopulateHeadings()
'Declarations.
Dim IntFirstColumn As Integer
Dim IntLastColumn As Integer
Dim IntRow As Integer
Dim IntFirstValue
Dim RngRange01 As Range
'Setting variables.
IntFirstValue = 1
IntRow = 4
IntFirstColumn = 8
IntLastColumn = Range("XFD4").End(xlToLeft).Column
'Setting first value in the first cell.
Cells(IntRow, IntFirstColumn).Value = IntFirstValue
'Setting RngRange01.
Set RngRange01 = Range(Cells(IntRow, IntFirstColumn + 1), Cells(IntRow, IntLastColumn - 1))
'Setting formulas in RngRange01.
RngRange01.FormulaR1C1 = "=RC[-1]+1"
'Copy-pasting the values in RngRange01.
RngRange01.Value = RngRange01.Value
End Sub
I know that this row is wrong:
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
I want to rank the whole column D in column E. The numbers should be "grouped" in 39 numbers.
Private Sub CommandButton2_Click()
Dim lrow As Long
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lrow = ws.Cells(Rows.Count, "D").End(xlUp).row 'Find the last row in column D
For i = 2 To lrow Step 39 'Loop every group (group of 13 rows) in column D
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
Next i
End Sub
I think the code will do what you want. Please pay attention to the constants at the top which you have to set to suit your needs.
FirstDataRow - your data seem to start in row 2. So, don't change.
GroupSize - I tested groups of 3 rows. I think you want groups of 39 rows. Change it.
TgtClm - Your data are in column 4 (column D). No need to change now.
Once you have set these 3 constants the code is ready to run. Please try it.
Private Sub CommandButton2_Click()
' 034
Const FirstDataRow As Long = 2
Const GroupSize As Long = 3 ' change to suit
Const TgtClm As Long = 4 ' Target Column (4 = column D)
' the output will be in the adjacent column
Dim Ws As Worksheet
Dim Rng As Range ' cells in one group
Dim lRow As Long ' last used row
Dim Rstart As Long ' first row in group range
Dim Rend As Long ' last row in group range
Set Ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lRow = Ws.Cells(Ws.Rows.Count, TgtClm).End(xlUp).Row 'Find the last used row
Rstart = FirstDataRow
Do
Rend = Application.Min(Rstart + GroupSize - 1, lRow)
With Ws
Set Rng = .Range(.Cells(Rstart, TgtClm), .Cells(Rend, TgtClm))
End With
Rng.Offset(0, 1).Formula = "=RANK(" & Rng.Cells(1).Address(0, 1) & _
"," & Rng.Address & ",0)"
Rstart = Rend + 1
If Rstart > lRow Then Exit Do
Loop
End Sub
Note that the final 0 in the RANK formula (here: & Rng.Address & ",0)") instructs to rank in desscending order, meaning the highest number will get the lowest rank (100 = 1, 90 = 2 etc). Change to 1 if you need the opposite order.
I do not know this topic so well, but on the webpage
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.rank_eq
Is written that expression.Rank_Eq (Arg1, Arg2, Arg3), and the
expression A variable that represents a WorksheetFunction object.
In your code it looks like a Range object.
I have created code for 1 blank row but I need to change it to 11 blank rows
I have 4000 values in A row. i need to insert 11 rows after each unique value found in A row
Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range
Set oRng = Range("a1")
iRow = oRng.Row
iCol = oRng.Column
Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
Cells(iRow + 11, iCol).EntireRow.Insert shift:=x1Down
iRow = iRow + 2
Else
iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub
So this code is inserting 1 blank row after each unique value.
I would like to change it to 11 blank rows.
Before:
After:
Scratch my last answer, as per your last comments (and screenshots):
"I have 4000 values in row A. i need 11 rows between each row value"
And:
"In my data value present in A row will be unique (i.e) Range A:A 4000 rows are unique"
This, to me, reads like all your values are unique. No need to test anything nomore then:
Sub Test()
Dim lr As Long, x As Long, ws As Worksheet
'Set your worksheet as variable
Set ws = ThisWorkbook.Worksheets("Sheet1")
'Get last used row of column A and fill array
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
'Loop backwards
For x = lr + 1 To 3 Step -1
ws.Rows(x).Resize(11).Insert xlShiftDown
Next x
End Sub
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub