I need a VBA code to copy dynamic range. The Rows look like below :
R1 - Title
R2 - Headers
R3 - Data
R97 - Data
R98 - Blank
R99 - Text
R100 - Title
R101 - Headers
R102 - Data
R150 - Blank
R151 - Text
R153 - Title
R153 - Headers
R154 - Data
I have a similar set of data in rows below further. I can't filter and copy because the header is only in 2 cells and there are blank rows in between. Note the columns are static here
I am looking for help to copy the data in a structured format.
I could find the below code in other conversation, which does copy only 2 rows below headers but doesn't ignore the blanks
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, c As Range
Dim vR(), n As Long, k As Integer, j As Integer
Dim Ws As Worksheet
With Worksheets("Trial Balance Detail") ' <-- here should be the Sheet's name
'.Columns("e").ClearContents
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("B1:B" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each c In rng
If c.Value = "Jrnl No." Then
For j = 1 To 2
n = n + 1
ReDim Preserve vR(1 To 13, 1 To n)
For k = 1 To 13
vR(k, n) = c.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
Next k
Next j
End If
Next c
If n > 0 Then
Set Ws = Sheets.Add '<~~~ Sheets("your sheet name")
With Ws
.Range("a1").Resize(n, 13) = WorksheetFunction.Transpose(vR)
End With
End If
End With
End Sub
Related
Hi I am ne w to excel VBA and getting by using loads of help online. I need to copy data with changing number of rows from multiple worksheets to a single worksheet starting at cell H4. The data columns are fixed. I don't need an empty row between the data in the destination worksheet. I have 20 source worksheets to transfer. My code so far for each worksheet copies the destination sheet using arrays. Also I am not sure how to make all the sheets copy in one operation.
Sub Adam_to_array()
Dim arr As Variant
arr = Sheet8.Range("P3").CurrentRegion.value
Dim i As Long
For i = LBound(arr, 1) To UBound(arr, 1)
Next i
Sheet100.Range("H4").CurrentRegion.ClearContents
Dim rowCount As Long, columnCount As Long
rowCount = UBound(arr, 1)
columnCount = UBound(arr, 2)
Sheet100.Range("H4").Resize(rowCount, columnCount).value = arr
End Sub
Sub Paul_to_array()
Dim arr As Variant
arr = Sheet7.Range("P4").CurrentRegion.value
Dim i As Long
For i = LBound(arr, 1) To UBound(arr, 1)
Next i
Dim rowCount As Long, columnCount As Long
rowCount = UBound(arr, 1)
columnCount = UBound(arr, 2)
Sheet100.Range("H").Resize(rowCount, columnCount).value = arr
If I understand you correctly and if it's OK with you that the sub is not using array .... below is the example data, table with 5 columns header :
x1 = the data in sheet "Sheet1"
x2 = the data in sheet "Sheet2"
x3 = the data in sheet "Sheet3"
The header starts in cell A1 on each sheet.
If your expected result in sheet "Output" is like this :
then the sub:
Sub test()
Dim ColStart As Long: Dim i As Long
Dim rg As Range: Dim oFill As Range
Dim sh As Worksheet
ColStart = 8
For Each sh In Sheets
If sh.Name <> "Output" Then
Set rg = sh.UsedRange
Set rg = rg.Resize(rg.Rows.Count - 1, rg.Columns.Count).Offset(1, 0)
For i = 1 To rg.Columns.Count
Set oFill = Sheets("Output").Cells(Rows.Count, ColStart - 1 + i).End(xlUp).Offset(1, 0)
If Application.CountA(rg.Columns(i)) <> 0 Then _
rg.Columns(i).Cells.SpecialCells(xlConstants).Copy Destination:=oFill
Next i
End If
Next sh
End Sub
Before running the sub, make a new sheet, name it "Output", and put all the columns header starting in cell H3.
There are two loops
A. Loop to each sheet which name is not "Output"
(The sub assumed that all the rest of the existing sheets in the workbook other than sheet "Output" is where the data need to be copied to sheet "Output").
B. Loop to each column of the existing data in the looped sheet.
In loop-A, it set the data range of the looped sheet into variable rg.
In loop-B (loop to each column in rg variable), it set where the last blank row (of the respected column in sheet "Output") into oFill variable, check if the looped column has data then copy the cell which has value in the looped column of the rg and paste it to oFill cell.
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 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 need code which should first count how many times loop should be executed (suppose I have 18000 rows then 18000/7000 = 2.57 so 3 times), and then it should start a loop and copy first 7000 rows and paste in sheet2, and then the next 7000 rows (7001 to 14000) and this should continue until the range is empty.
I am referring to this code shown here, but it is not helping me out:
Dim r As Long
Dim c As Long
c = GetTargetColumn() ' Or you could just set this manually, like: c = 1
With Sheet1 ' <-- You should always qualify a range with a sheet!
For r = 1 To 7000 ' Or 1 To (Ubound(MyListOfStuff) + 1)
' Here we're looping over all the cells in rows 1 to 10, in Column "c"
.Cells(r, c).Value = MyListOfStuff(r)
'---- or ----
'...to easily copy from one place to another (even with an offset of rows and columns)
.Cells(r, c).Value = Sheet2.Cells(r + 3, 17).Value
Next r
End With
"This should continue until the range is empty." My code below copies the entire range but doesn't delete the original as your descriptions seems to imply. That should be quite easy, however, if required - just WsS.Cells.ClearContentsadded at the end.
Meanwhile, the code does what you describe. The number of rows to be copied in one loop can be set at the top of the procedure. I set Const BlockRowCount As Long = 3, doing 3 rows in a loop. It will also work for 7000 rows.
I noticed that your code doesn't seem to copy A1 to A1. Const FirstTargetCell As String = "B3" defines the top-left cell in the destination sheet as B3. You can specify any cell you want in that location and the code will hang the data from that peg.
Sub TransferData()
Const BlockRowCount As Long = 3
' cell A1 from the source sheet will arrive at
' FirstTargetCell on the target sheet. All other data relative to it.
Const FirstTargetCell As String = "B3" ' modify as required
Dim WsS As Worksheet ' Source sheet
Dim WsT As Worksheet ' Target sheet
Dim Src As Range ' source data range
Dim Tgt As Range ' target data range
Dim Arr As Variant ' data array
Dim Rl As Long, Cl As Long ' last used row / column
Dim Ct As Long ' first Target column
Dim Rs As Long, Rt As Long ' source / target row
Dim R As Long
Set WsS = Worksheets("Source Data")
Set WsT = Worksheets("Destination")
With Range(FirstTargetCell)
Rt = .Row
Ct = .Column
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With WsS
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Rs = 0 To Abs(Int(Rl / BlockRowCount * -1)) - 1
R = Application.Min((Rs + 1) * BlockRowCount, Rl)
Set Src = .Range(.Cells(Rs * BlockRowCount + 1, 1), _
.Cells(R, Cl))
Arr = Src.Value
With WsT
Set Tgt = .Cells(Rt, Ct).Resize(UBound(Arr), UBound(Arr, 2))
Tgt.Value = Arr
End With
Rt = Rt + BlockRowCount
Next Rs
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Having issues with some vba, if anyone can point me in the right direction it would be greatly appreciated, currently my code is returning a full row of data and it is returning multiple rows, this is my current code.
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
For Each c In Source.Range("G6:K6") ' Do 50 rows
If c.Text = "OVER" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
I need to look at each row and in each row if the word "OVER" appears I need it to return the information in the side bar e.g. column B I would need this to apply for each wee section e.g. Column C- F should return the number from column B and H-K should return G etc.
This?
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
If c.Text = "OVER" Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
j = j + 1
End If
Next c
Next i
End Sub
EDIT
If don't want repeated rows, try this one:
Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
j = 3 ' Start copying to row 1 in target sheet
a = 1
For i = 1 To 3 'Number of ¿wees?
For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
If c.Text = "OVER" Then
If a <> c.Row Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
j = j + 1
a = c.Row
End If
End If
Next c
Next i
End Sub
you could try this code (commented)
Option Explicit
Sub BUTTONtest_Click()
Dim Source As Worksheet
Dim Target As Worksheet
Dim iSection As Long
Dim sectionIniCol As Long, sectionEndCol As Long
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")
With Source '<--| reference 'Source' sheet
With .Range("B6:F" & .Cells(.Rows.Count, "B").End(xlUp).row) '<--| reference its columns "B:F" range from row 6 down to last non empty cell in column "B"
With .Offset(, -1).Resize(, 1) '<--| reference corresponding cells in column "A" (which is an empty column)
For iSection = 1 To 3 '<-- loop over all your three 5-columns sections
sectionIniCol = (iSection - 1) * 5 + 2 '<-- evaluate current section initial col
sectionEndCol = sectionIniCol + 4 '<-- evaluate current section ending col
.FormulaR1C1 = "=if(countif(RC" & sectionIniCol + 1 & ":RC" & sectionEndCol & ",""OVER"")>0,1,"""")" '<-- write (temporary) formulas in column "A" cells to result "1" should at least one "OVER" occurrence be in corresponding cells of current section columns
If WorksheetFunction.Sum(.Cells) > 1 Then Intersect(.Columns(sectionIniCol), .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow).Copy Target.Cells(Target.Rows.Count, 1).End(xlUp).Offset(1) '<-- if any occurrence of "OVER" has been found then copy section initial column cells corresponding to column "A" cells marked with "1" and paste them in from first empty row of 'Target' sheet...
Next iSection
.ClearContents '<--| delete (temporary) formulas in target column "A"
End With
End With
End With
End Sub