I am very new to VBA and trying to consolidate an excel file with 0.2 million rows.
My excel format is
You can see that so much duplicated data there. I want to make the whole sheet have only 4 columns by appending other columns data as the headers are same.
For example :
Data in the columns F2-I2 will go to A4 - D4
F3 - I3 will go to A5 - D5
similarly
K2 - N2 will go to A6 - D6
K3 - N3 will go to A7 - D7
And follows
I want to write a VBA macro and by running the macro it should make the excel have only 4 columns by appending all other columns data.
Can someone please help me achieving that.
NOTE : After doing that my excel will have around 1 million rows. So i am looking for a solution with good performance.
I think this only can be solved by looping through the blocks, the columns and the rows which probably takes some time if you have a million values.
To increase performance disable screenUpdating and to ensure that the macro does not crash include DoEvents() in the loop.
Please note that the maximum number of rows in Excel is 1'048'576
Sub moveValues()
Application.ScreenUpdating = False
Dim i As Integer
Dim j As Integer
Dim k As Long
Dim row As Long
Dim col As Integer
Dim lastRowTarget As Long
Dim lastRowSource As Long
Dim wks As Worksheet
Set wks = Sheets("Sheet1")
For i = 6 To 16 Step 5
lastRowSource = wks.Cells(Rows.Count, Chr(64 + i)).End(xlUp).row
lastRowTarget = wks.Cells(Rows.Count, "A").End(xlUp).row
col = 1
For j = i To i + 3
For k = 2 To lastRowSource
wks.Cells(lastRowTarget + k - 1, col) = wks.Cells(k, j)
DoEvents
Next k
col = col + 1
Next j
Next i
Application.ScreenUpdating = True
End Sub
Related
Let's say I have a table: the columns correspond to years (such as 1999, 2000, ..., 2020) and the rows are countries.
How can I make Excel display only the top 10 values of each column and set other countries values =0 ?
I assume the first cell ("Country") is the cell A1.
Open your sheet.
Alt + F11
Insert => Module
Paste this code:
Sub leave_top_10_on_every_column()
Dim iLastRow As Long
Dim iLastCol As Long
Dim i As Long
Dim j As Long
Dim dblTop10 As Double
iLastRow = ActiveSheet.Cells(1, 1).End(xlDown).Row
iLastCol = ActiveSheet.Cells(1, 1).End(xlToRight).Column
For i = 2 To iLastCol
dblTop10 = WorksheetFunction.Large(ActiveSheet.Cells(1, i).EntireColumn, 10)
For j = 2 To iLastRow
If ActiveSheet.Cells(j, i) < dblTop10 Then ActiveSheet.Cells(j, i) = 0
Next
Next
End Sub
Put the mouse pointer somewhere in the middle of this code and hit F5 to run the code.
Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function
I have a workbook containing 197 sheets. I need to delete all rows in each sheet if the value in column AA is zero. Anyone know how to do this?
If you would like to delete each row if and only if that row's column AA is zero, then the below should work for you.
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= lastRow
If Worksheet.Range("AA" & i).Value = 0 Then
Worksheet.Rows(i).Delete
i = i - 1
lastRow = lastRow - 1
End If
i = i + 1
Loop
Next
End Sub
Note this will only delete the row if the cell value in AA is 0. There are several subtleties here... Excel will show a 0 even if the cell value is '0 or =0 among other things, and those rows will not be deleted with the above code.
I am currently working on a problem where I have an Excel Spreadsheet that I would like to use a VBA macro on. Each of the following 3 rows are consecutive.
Name of Data
abc A1 B2 B4 C4 E2 F43 d4 V8 f9 k11 j20 … x
cde A2 B3 B12 C6 E9 F34 d6 V4 f13 k111 j209 … x
efg A3 B5 B7 C8 E11 F68 d19 V12 f91 k114 j2014 … x
…
Desired
abc A1 B2 B4 C4 E2 F43 d4 V8
abc f9 k11 j20 …
cde A2 B3 B12 C6 E9 F34 d6 V4
cde f13 k111 j209 …
efg A3 B5 B7 C8 E11 F68 d19 V12
efg f91 k114 j2014 …
I have the data name for each row and some rows can be hundreds of entries long spanning hundreds columns. So what I would like to do would be make my row length stop at 8 columns wide. I would hope that the macro can check through each row to see if the length is greater than 8, insert a row with the same data name and paste the next 8 columns, subtract it from the total columns and paste the next row, until it has reached the end of the first long row, and continue checking through all the rows. In essense, it saves a whole lot of time from counting up 8 columns wide, cut and pasting it in an inserted row below, preserving all other data. I'm new to this, so macro or VBA help is much appreciated.
Thanks,
John
The below macro will do exactly as you ask. It has some assumptions that I'll leave to you to fix, such as
Data is in sheet 1
Name column is always A, all data columns start from B
Everything starts in cell A1
This macro will run through every row and, for those rows with more than 9 data elements, it will create a new row and populate it with the previous rows Name and the remaining data rows. It will continue doing this until there is less than or equal to 8 data elements per row.
Since you have MANY rows you say, it would be a good idea to turn off screen updating, like so Application.ScreenUpdating = False before the for loop and turn it back on after the for loop.
Public Sub SplitRows()
Dim rowRange As Variant
Dim colCount As Integer
Dim lastColumn As Long
Dim rowCount As Integer
rowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
i = 1
Do While (i < rowCount)
lastColumn = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column
colCount = Sheet1.UsedRange.Columns.Count
rowRange = Range(Cells(i, 2), Cells(i, colCount))
'if the row has more than 9 values (name column + 8 data columns)
If Not lastColumn <= 8 Then
Dim x As Integer
'from column 2 (B, aka first data column) to last column
For x = 2 To colCount - 1
'if data is not empty AND x mod 8 is 1 (meaning 8 goes into x enough times to have a remainder of 1)
If Not IsEmpty(rowRange(1, x - 1)) And (x Mod 8) = 1 Then
Cells(i, 1).Offset(1).EntireRow.Insert 'insert new row below current row
rowCount = rowCount + 1 'update row count because we added a row
Sheet1.Cells(i + 1, 1).Value = Sheet1.Cells(i, 1).Value 'set first column name
Dim colsLeft As Integer
For colsLeft = x To colCount - 1
'take data value from col 9 to end and populate newly created row
Sheet1.Cells(i + 1, colsLeft - 7).Value = rowRange(1, colsLeft)
Sheet1.Cells(i, colsLeft + 1).Value = "" 'set data value from col 9 on and set to empty
Next
Exit For 'exit loop, weve done all we need to and must now check the newly populated row
End If
Next
End If
i = i + 1
Loop
End Sub
Here is a before and after of the results:
BEFORE
AFTER
Argh, I tried somewhat along this lines, but I have to go to work. Maybe it is helpful as a starting point.
Public Sub Test()
Dim mastercell As Range
Set mastercell = ActiveWorkbook.Worksheets(1).Cells(1, 1)
Dim masterValue As String
masterValue = mastercell.Value
If GetCount(masterValue) > 8 Then
Dim tempvalue As String
tempvalue = masterValue
Dim Rowcount As Integer
Dim ColCount As Integer
Rowcount = mastercell.Row
ColCount = mastercell.Column + 1
Do While GetCount(tempvalue) > 8
Dim WriteValue As String
WriteValue = GetFirstEight(tempvalue)
ActiveWorkbook.Worksheets(1).Cells(Rowcount, ColCount).Value = WriteValue
ColCount = ColCount + 1
tempvalue = Replace(tempvalue, WriteValue, 0, 1)
Loop
End If
End Sub
Private Function GetCount(str As String) As Integer
Dim Splitter As String
Splitter = " "
Dim SplitArray As Variant
SplitArray = Split(str)
GetCount = UBound(SplitArray)
End Function
Private Function GetFirstEight(str As String) As String
Dim i As Integer
Dim NewString As String
Dim SplitArray() As String
SplitArray = Split(str)
For i = 0 To 7
NewString = NewString & SplitArray(i) & " "
Next
GetFirstEight = NewString
End Function
I have columns in 3 excel sheets like this:
Sheet1
ColA ColB
5 4
5 5
45 56
56 56
Sheet2
ColA ColB
53 24
55 55
Sheet3
ColA ColB
45 56
56 56
3 4
I want to copy paste columns from sheet 2 and 3 to sheet 1 and I am not sure of the row numbers as they can change based on the data.
Can anyone tell me the macro code to this without being sure of last data row in excel sheet.
I would really appreciate your suggestion.
If you just want to move the values, the following is what you are after. If you want to move the formatting as well, ask.
Sub CopyToSheet1()
Dim Row1Max As Long
Dim Row1Next As Long
Dim Row23Max As Long
Dim Values() As Variant
' Find bottom rows of sheets 1 and 2
' These statements position a virtual cursor to the bottom of column 1
' and then move up until they find data. For Sheet 1 it adds one because
' it needs the first blank row
Row1Next = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
Row23Max = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
' Extract data from sheet 2
Values = Worksheets("Sheet2").Range("A1:B" & Row23Max).Value
' Drop into sheet 1
Row1Max = Row1Next + Row23Max - 1
Worksheets("Sheet1").Range("A" & Row1Next & ":B" & Row1Max).Value = Values
Row1Next = Row1Max + 1
' Find bottom row of sheet3
Row23Max = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
' Extract data from sheet 3
Values = Worksheets("Sheet3").Range("A1:B" & Row23Max).Value
' Drop into sheet 1
Row1Max = Row1Next + Row23Max - 1
Worksheets("Sheet1").Range("A" & Row1Next & ":B" & Row1Max).Value = Values
End Sub
I have often used a function
Function CountRows(r as Range) As Long
CountRows = r.Worksheet.Range(r,r.End(xlDown)).Rows.Count
End Function
Then to copy and paste
Sub CopyRange(r_src as Range, r_dst as Range, numrows as Long, numcols as Long)
r_dst.Resize(numrows,numcols).Value2 = r_src.Resize(numrows,numcols).Value2
End Dub
Which you use it like this
Dim N as Long
Dim r_dst as Range, r_src as Range
' Pick first cell on sheet 1
Set r_dst = Sheet1.Range("A1")
' Count existing data and move to end
N = CountRows(r_dst)
Set r_dst = r_dst.Offset(N,0)
' Pick first cell of sheet 2 and count rows
Set r_src = Sheet2.Range("A1")
N = CountRows(r_src)
' Copy rows to sheet 1
CopyRange r_src, r_dst, N, 2
' Move to end of data on sheet 1
Set r_dst = r_dst.Offset(N,0)
' Pick first cell on sheet 2 and count rows
Set r_src = Sheet3.Range("A1")
N = CountRows(r_src)
' Copy rows to sheet 1
CopyRange r_src, r_dst, N, 2