VBA, Data into Rows instead of Columns and Filldown? - excel

I am writing to column C, but the data goes ex: C1:X1, instead I would like it by row. (ex: C1:C25) I would like it to be transposed vertically down the rows instead of horizontally.
The problem with this is I want the columns A&B to be filled down with this transposition in unisen. So A1:A25 would have the file name and C1:c25 would have my headers.
As I start to add more columns I would like to be able to add more columns and fill down to these aswell. (only filldown columns A and B)
any Ideas?
Code:
Dim iIndex As Integer
Dim lCol As Long
Dim lOutputCol As Long
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
Function:
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

You should just be able to change the lOutputCol from an incremented value to a static columnC. And you will have to add a lRow count increment inside the loop.
Change
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the headers
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
to
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Write the headers
wsReport.Range("C" & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
'Increment the row we are writing to
lRow = lRow + 1
Next lCol

Related

copy/paste range of cells x times based on condition

I want to fill each empty cells of a board with a precise range of data.
I 've got two worksheets;
-worksheets("Board")
- worksheets("FinalBoard")
In worksheet worksheets("Board") I've got the following board ;
Category
Fruits-1
Fruits-2
Fruits-3
A
Banana
Cherries
Orange
D
Apple
Mango
Strawberries
B
Pineapple
Watermelon
Grenade
I want to pick each columns data only if the header starts with "Fruits" and paste them in one colum in worksheet worksheets("FinalBoard") . I was able to do so with columns named Fruits, with the following code;
Sub P_Fruits()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get columns name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste in the 2nd worksheet every data if the headers is found
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
end with
end sub
however I'd like to do so for the column "category" and put the category's type in front of each fruits in column A and thus repeat the copied range category multiple time , as much as there were headers beginning with "Fruits" in worksheets("Board") . I tried to add an extra code to the previous one but it didnt work. Here is what I'd like as a result;
Category-pasted
Fruits-pasted
A
Banana
D
Apple
B
Pineapple
A
Cherries
D
Melon
B
Watermelon
A
Orange
D
Strawberries
B
Grenade
Here is what I had with the code I added instead...
Category-pasted
Fruits-pasted
Banana
Apple
Pineapple
Cherries
Melon
Watermelon
Orange
Strawberries
Grenade
A
D
B
My finale code;
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
'Code to repeat category type added
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Category*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("A" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> copy-paste each category type in column A
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With
End With
I feel like I'm close to the solution. I'd appreciate your help guys, thank you!
This code will produce the required results but uses a different approach.
The first thing it does is read the source data into an array, it then goes through that array and extracts the fruits/categories from every column with a header starting with 'Fruit.
Option Explicit
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim cnt As Long
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
' assumes data on 'Board' starts in A1
With wsInput
arrDataIn = .Range("A1").CurrentRegion.Value
End With
ReDim arrDataOut(1 To 2, 1 To UBound(arrDataIn, 1) * UBound(arrDataIn, 2))
For idxCol = LBound(arrDataIn, 2) To UBound(arrDataIn, 2)
If arrDataIn(1, idxCol) Like "Fruits*" Then
For idxRow = LBound(arrDataIn, 1) + 1 To UBound(arrDataIn, 1)
cnt = cnt + 1
arrDataOut(1, cnt) = arrDataIn(idxRow, 1)
arrDataOut(2, cnt) = arrDataIn(idxRow, idxCol)
Next idxRow
End If
Next idxCol
If cnt > 0 Then
ReDim Preserve arrDataOut(1 To 2, 1 To cnt)
End If
With wsOutput
.Range("A1:B1").Value = Array("Category-pasted", "Fruit-pasted")
.Range("A2").Resize(cnt, 2) = Application.Transpose(arrDataOut)
End With
End Sub
As I explained in my comments you don't need the second loop if you already found the correct row - get the category column early and reuse it later
You can add this variable declaration at the top first
Dim col As String
Then continue with your code for first loop (deleting second loop
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
Add this to retrieve categories first
If .Cells(1, i).Value2 Like "Category*" Then
'~~> Get column name
colCat = Split(.Cells(, i).Address, "$")(1)
End If
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
Then add this to paste the categories
'~~> copy-paste each category type in column A
.range(colCat & "2:" & colCat & lRowInput).Copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With

Copy specific cells from sheet to sheet based on condition

'Sub CopyRowToSheet23()
Worksheets("Sheet2").Range("A2:E1000").Clear
Dim LastRowSheet1, LastRowSheet2 As Long
Dim i As Long
Application.ScreenUpdating = False
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A2:E" & LastRowSheet2).ClearContents
LastRowSheet1 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1")
For i = 2 To LastRowSheet1 Step 1
If Cells(i, "E").Value = "YES" Then
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Rows(i).Copy Worksheets("Sheet2").Range("A" & LastRowSheet2 + 1)
End If
Next i
End With
Application.ScreenUpdating = True
Sheet3.Select
End Sub'
I´ve managed to create the code above to get all rows that have "yes" in column E. However, I´m having issues when trying to run the macro in other sheets different than Sheet1. I would like to run it in sheet3 but I haven´t found why it does not help.
Try:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wsRE As Long, i As Long, LastrowC As Long, LastrowE As Long, LastrowF As Long
'Set ws1
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'Set ws2
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
wsRE = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
'Starting from Row 2 - let us assume that their is a header
For i = 2 To wsRE
'Check if the value in column E is yes
If ws2.Range("E" & i).Value = "Yes" Then
'Find the Last row in Sheet1 Column C
LastrowC = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
'Copy row i, Column A from Sheet 1 and paste it in Sheet 2 after the lastrow in column C
ws2.Range("A" & i).Copy ws1.Cells(LastrowC + 1, 3)
'Find the Last row in Sheet1 Column E
LastrowE = ws1.Cells(ws1.Rows.Count, "E").End(xlUp).Row
'Copy row i, Column B from Sheet 1 and paste it in Sheet 2 after the lastrow in column E
ws2.Range("B" & i).Copy ws1.Cells(LastrowE + 1, 5)
'Find the Last row in Sheet1 Column F
LastrowF = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
'Copy row i ,Column C from Sheet 1 and paste it in Sheet 2 after the lastrow in column F
ws2.Range("C" & i).Copy ws1.Cells(LastrowF + 1, 6)
End If
Next i
End Sub

Excel Macro - Fetching the values of one column based on the values from other column

I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub

excel programatically merge all rows with equal values in column z

I'm running a dataimport macro, and I want to merge all rows in a dataset that have equal values in column x, and then I want to get a row that represents the average of group x[y] x being the column, and y being the value of the column x for that particular grouping.
Is there a simple function to do this, or must I create an extensive loop with a lot of spare cycles?
Explicitation:
So my dataset looks like
A | B | C
1 2 4
1 2 5
2 7 3
2 5 1
3 2 1
1 5 6
Now I want to merge rows by column A value, so all A's with equal value get the rest of their rows averaged so I would get somethin that looked like:
A | B | C
1 3 5
2 6 2
3 2 1
So far I've been trying to loop over the possible values of column A (1 to 10) manually by this function, but it keeps crashing excel, and I can't figure out why, I must have an endless loop somewhere in this function:
Function MergeRows(sheet, column, value)
Dim LastRow
Dim LastCol
Dim numRowsMerged
Dim totalValue
numRowsMerged = 1
LastRow = sheet.UsedRange.Rows.Count
LastCol = sheet.UsedRange.Columns.Count
With Application.WorksheetFunction
For iRow = LastRow - 1 To 1 Step -1
'enter loop if the cell value matches what we're trying to merge
Do While Cells(iRow, column) = value
For iCol = 1 To LastCol
'skip the column that we're going to use as merging value, and skip the column if it contains 3 (ikke relevant)
If Not (iCol = column) And Not (Cells(iRow, iCol) = 3) Then
Cells(iRow, iCol) = (Cells(iRow, iCol) * numRowsMerged + Cells(iRow + 1, iCol)) / (numRowsMerged + 1)
End If
Next iCol
'delete the row merged
Rows(iRow + 1).Delete
Loop
'add one to the total number of rows merged
numRowsMerged = numRowsMerged + 1
Next iRow
End With
End Function
solution
I ended up creating a range that I would gradually extend using Union, like this:
Function GetRowRange(sheet, column, value) As range
Dim LastRow
Dim LastCol
Dim numRowsMerged
Dim totalValue
Dim rowRng As range
Dim tempRng As range
Dim sheetRange As range
numRowsMerged = 1
Set sheetRange = sheet.UsedRange
LastRow = sheet.UsedRange.Rows.Count
LastCol = sheet.UsedRange.Columns.Count
With Application.WorksheetFunction
For iRow = 1 To LastRow Step 1
'enter loop if the cell value matches what we're trying to merge
If (sheetRange.Cells(iRow, column) = value) Then
Set tempRng = range(sheetRange.Cells(iRow, 1), sheetRange.Cells(iRow, LastCol))
If (rowRng Is Nothing) Then
Set rowRng = tempRng
Else
Set rowRng = Union(rowRng, tempRng)
End If
End If
'add one to the total number of rows merged
numRowsMerged = numRowsMerged + 1
Next iRow
End With
Set GetRowRange = rowRng
End Function
Is this what you are trying? Since you wanted VBA code, I have not used Pivots but used a simpler option; formulas to calculate your average.
Option Explicit
Sub Sample()
Dim col As New Collection
Dim wsI As Worksheet, wsO As Worksheet
Dim wsIlRow As Long, wsOlRow As Long, r As Long, i As Long
Dim itm
'~~> Chnage this to the relevant sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> Work with the input sheet
With wsI
wsIlRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> get unique values from Col A
For i = 1 To wsIlRow
On Error Resume Next
col.Add .Range("A" & i).Value, """" & .Range("A" & i).Value & """"
On Error GoTo 0
Next i
End With
r = 1
'~~> Write unique values to Col A
With wsO
For Each itm In col
.Cells(r, 1).Value = itm
r = r + 1
Next
wsOlRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Use a simple formula to find the average
For i = 1 To wsOlRow
.Range("B" & i).Value = Application.Evaluate("=AVERAGE(IF(" & wsI.Name & _
"!A1:A" & wsIlRow & "=" & .Range("A" & i).Value & _
"," & wsI.Name & "!B1:B" & wsIlRow & "))")
.Range("C" & i).Value = Application.Evaluate("=AVERAGE(IF(" & wsI.Name & _
"!A1:A" & wsIlRow & "=" & .Range("A" & i).Value & _
"," & wsI.Name & "!C1:C" & wsIlRow & "))")
Next i
End With
End Sub
SCREENSHOT
This is easy to do with a pivot table.
Here's a picture of the end result.

Autofill Dynamic Range Last Row and Last Column

I have a workbook containing multiple sheets of varying sizes. I want to add a total column after the last row and copy the formula across all columns. I have defined the last row and column and the formula appears as expected in the correct place but I receive an error when trying to fill across. How do I correctly reference both dynamic cells for the fill? I'm just using a single sheet for now for testing but will eventually be looping through all the sheets in the book.
Sub Addtotals()
Dim Bord As Worksheet
Dim LRow As Long
Dim LCol As Long
Dim frmcell As Range
Set Bord = Sheets("Borders")
With Bord
'--> Define last rows and columns
LRow = .Range("A" & Rows.Count).End(xlUp).Row
LCol = .Range("A" & Columns.Count).End(xlToLeft).Column
'--> Add Total text to first column
.Range("A" & LRow).Offset(1, 0).Select
ActiveCell = "Total"
'--> Add formula to next column
Set frmcell = Range("B" & LRow + 1)
frmcell.Formula = "=sum(B2:B" & LRow & ")"
'--> Fill formula across range
frmcell.Select
Selection.AutoFill Destination:=Range(frmcell & LCol), Type:=xlFillDefault
End With
End Sub
Thanks :)
Like this?
Option Explicit
Sub Addtotals()
Dim Bord As Worksheet
Dim LRow As Long, LCol As Long
Set Bord = Sheets("Borders")
With Bord
'--> Define last rows and columns
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'--> Add Total text to first column
.Range("A" & LRow).Value = "Total"
'--> Fill formula across range
.Range("B" & LRow & ":" & _
Split(Cells(, LCol).Address, "$")(1) & LRow).Formula = _
"=Sum(B2:B" & LRow - 1 & ")"
End With
End Sub

Resources