I have a column of data (F) and a column of numbers (G), and I want to copy each row of column F and paste to column H for a number of times, which depends on the corresponding value in column G.
How could I do it using vba?
For exemple:
F G H
4 Q7-CA 1 Q7-CA
5 Q5-CA 2 Q5-CA
6 A1-CA 1 Q5-CA
7 Q6-CA 4 A1-CA
8 BULK-TACEHU 1 Q6-CA
9 AMA-EG 2 Q6-CA
10 Q6-CA
11 Q6-CA
12 BULK-TACEHU
13 AMA-EG
14 AMA-EG
Use the code below, I used row 1 as the row where the data starts (modify according to your needs) :
Option Explicit
Sub CopyNumofTimes()
Dim LastRow As Long
Dim Sht As Worksheet
Dim lRow As Long
Dim newRow As Long
Dim CopyRep As Integer
Dim cpyRow As Integer
' modify Sheet1 to your Sheet name
Set Sht = ThisWorkbook.Sheets("Sheet1")
' modify 1 form the line number you are starting your data
newRow = 1
With Sht
' find last row with data in Column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For lRow = 1 To LastRow
CopyRep = .Cells(lRow, "G").Value
' make sure you have a number of at least 1 in Column G
If CopyRep > 0 Then
For cpyRow = 1 To CopyRep
.Cells(newRow, "H") = .Cells(lRow, "F")
newRow = newRow + 1
Next cpyRow
End If
Next lRow
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 trying to number column A in increments by 1, based on how many rows are in column B Example of my Excel sheet
The code I currently have does this, but the top number does not end up being 1. I need to start with 1 at the top and count down.
Sub SecondsNumbering()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Data Formatted")
Dim LastRow As Long
Dim i As Long
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 6 To LastRow
.Cells(i, 1).Value = i - 1
Next
End With
End Sub
With this, I am counting the number of rows in the column.
Edit: When I do the value 7 for i, so that it starts at 6 (which is where I want data to start) this is what I get.
How about...
Option Explicit
Sub Test()
Dim lCntr As Long
lCntr = 6
Do
If (Cells(lCntr, 2) <> "") Then Cells(lCntr, 1) = lCntr - 5
lCntr = lCntr + 1
Loop Until Cells(lCntr, 2) = ""
End Sub
HTH
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 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
I have data in a column and I am trying to run a macro so that a new row (a preset line) is inserted every time a new value is found.
Here is an example of how the data looks currently:
1 C 100
1 D 100
1 E 100
1 F 100
1 G 100
2 C 200
2 D 200
2 E 200
I want the macro to look in the first column and if there is a new value then insert a row (paste a predefined line)
This is the outcome:
1 C 100
1 D 100
1 E 100
1 F 100
1 G 100
Predefined line copied
2 C 200
2 D 200
2 E 200
Predefined line copied
My current code looks like this. It is not working:
Sub InsertCreditorLine()
'based on value in column AB, works out where new expense starts and inserts the creditor line formula row
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim PrintArea1 As Variant
Dim R As Long
Dim StartRow As Long
' works out last row to work up from
Col = "AB"
StartRow = 6
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
'Looks to value in column AB to see where new expense starts
If .Cells(R, Col) = "Y" Then
'paste in line
Rows("1:13").Select
Selection.EntireRow.Hidden = False
.Cells(7, 7).EntireRow.Copy
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.CutCopyMode = False
How about this?
Sub InsertCreditorLine()
Dim startRow As Long, lastRow As Long, presetRow As Range, rw As Long
startRow = 6
lastRow = Range("AB" & Rows.Count).End(xlUp).Row
Set presetRow = Range("7:7")
For rw = lastRow To startRow + 1 Step -1
If Range("AB" & rw) <> Range("AB" & rw).Offset(-1, 0) Then
presetRow.Copy
Range("AB" & rw).Insert Shift:=xlDown
End If
Next rw
End Sub