I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.
Related
I'm trying to create a VBA script that goes into file1 and copies the data into file2. File 1 contains the data.
The issue I'm having is file2 has more columns and not necessarily in the same order as the ones in file1. As well, the Range is wrong, I'm not sure how to select all relevant data. How do i make sure it gets all the relevant rows per column in file1?
Sub GetDatacClosedBook()
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\Data\Documents\File1", True, True)
Set wbOpen = ActiveWorkbook
'this is the workbook in which the data will be transferred to
Workbooks.Open "C:\Users\Data\Documents\file2.xlsx"
Worksheets("Sheet1").Range("A1:D3").Formula = src.Worksheets("Sheet1").Range("A1:D3").Formula
wbOpen.Close
End Sub
You should first figure out the columns in your data sheet match which columns in your destination sheet. And then everything should be easy. This can be done in multiple way. I assume your A row has the headers, then you can match the column by match the headers
Sub Macro()
Dim destSht As Worksheet, srcSht As Worksheet
Dim src_ColCnt As Integer, dest_ColCnt As Integer
'Open the workbooks and grab the sheet reference, assign it to a worksheet variables
Set srcSht = Workbooks.Open("D:\data.xlsx").Sheets("Sheet1")
Set destSht = Workbooks.Open("D:\report.xlsx").Sheets("Sheet1")
'Find how many columns in your destination sheet, how many columns in your source sheet and how many rows the source sheet data has.
dest_ColCnt = destSht.Range("A1").End(xlToRight).Column
src_ColCnt = srcSht.Range("A1").End(xlToRight).Column
src_RCnt = srcSht.Range("A1").End(xlDown).Row - 1
'The code below is basically loop over the source sheet headers, and for each header
'find the column in your destination that has the same header
'And then assign the data row by row once it knows which column in the data sheet go to which column in the destination sheet
For i = 1 To src_ColCnt
Header = srcSht.Cells(1, i)
For j = 1 To dest_ColCnt
If destSht.Cells(1, j).Value = Header Then
For r = 1 To src_RCnt
'Do your assignment here row by row
'You can assign formula, value or different thing based on your requirement
'I assume your data start from the second row here
destSht.Cells(r + 1, j).Value = srcSht.Cells(r + 1, i).Value
Next r
End If
Next j
Next i
End Sub
This is not elegant but should give you the idea. To make the above more elegant, There are a couple of things you can use. One, using Scripting.Dictionary data structure to hold the headers in the dictionary as key, the column ordinal as the value. And then you loop your destination sheet column by column. Retrieve the right column ordinal from the dictionary. Two, you can use WorksheetFunctions.Match() to find the ordinal. Or even better if you know the order by yourself. You can just hard coding an order Array, like mapOrder = Array(3,1,5,6) and just use this array to match the column.
You could write a function that points to a specific workbook, locates a column -perhaps by heading- and captures that columns data into an Array which is returned by the function.
Then write the arrays in the desired order to the other sheet.
Example for the Subroutine and the function:
Private Sub GetDatacClosedBook()
Dim ExampleArray As Variant
Dim Destination As Range
ExampleArray = LocateColumnReturnArray(ThisWorkbook.Sheets("Sheet1"), "Value to find in row1 of the desired column")
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A1")
Destination.Resize(UBound(ExampleArray), 1) = ExampleArray
End Sub
Public Function LocateColumnReturnArray(ByRef TargetWorksheet As Worksheet, ByVal TargetColumnHeader As String) As Variant
Dim LastUsedColumn As Long
Dim TargetCell As Range
With TargetWorksheet
LastUsedColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each TargetCell In .Range(.Cells(1, 1), .Cells(1, LastUsedColumn))
If TargetCell.Value = TargetColumnHeader Then
LastUsedRow = .Cells(.Rows.Count, LastUsedColumn).End(xlUp).Row
LocateColumnReturnArray = .Range(.Cells(2, TargetCell.Column), .Cells(LastUsedRow, TargetCell.Column))
Exit Function
End If
Next TargetCell
End With
End Function
You can take this concept and apply it to your requirements.
This function could be run as many times as required for each column you want the data for.
You would need to also specify the target for each column of data but you could modify the above to use a loop based on the columns your data is being written to.
Essentially, I have data in three columns and a model on a separate tab. The data tab has 1,000 rows of data, and each entry will be run through the model, with results being pasted into the fourth column.
Here's what one iteration would look like, but I need it to loop through every row.
Worksheets("Data").Range("E2:G2").Copy _
Worksheets("Model").Range("B4:D4").PasteSpecial Paste:=xlPasteValues
Calculate
Worksheets("Model").Range("C120").Copy_
Worksheets("Data").Range("H2").PasteSpecial Paste:=xlPasteValues
Worksheets("Model").Range("C121").Copy_
Worksheets("Data").Range("I2").PasteSpecial Paste:=xlPasteValues
Worksheets("Model").Range("C122").Copy_
Worksheets("Data").Range("J2").PasteSpecial Paste:=xlPasteValues
Then we'd copy the next row of data from the Data tab (i.e., range E3:G3).
This seems like a classic loop scenario, but I don't know how to write it in VBA.
You can do this on a range, I see two ways you can do it, using a copy and paste or simply replicating a transposed version of the data:
'Copy and paste method
Worksheets("Model").Range("C120:C" & range("C" & rows.count).end(xlup).row).Copy 'Using the .end(xlup) will find the last row of data without looping until blank.
Worksheets("Data").Range("H2").PasteSpecial xlPasteValues,,,True 'The True here is what tells the pastespecial to transpose
'Transpose method
Worksheets("Data").Range("H2:J2").Value = application.transpose(Worksheets("Model").range("C120:C122"))
Each have their advantage, the Copy and Paste method is easier because you don't need to know the end column so it works easier for a dynamic range, the transpose method doesn't use the clipboard so is less impact on your system.
The better method code wise would be the transpose method.
You can then set up a simple For Next loop to run through as many data ranges as you want.
Dim DataRow As Long, MyDat As Worksheet, MyModel As Worksheet
Set MyDat = Worksheets("Data")
Set MyModel = Worksheet("Model")
For DataRow = 2 To MyDat.Range("E" & Rows.Count).End(xlUp).Row
MyModel.Range("B4:D4").Value = MyDat.Range("E" & DataRow & ":G" & DataRow).value
Calculate
MyDat.Range("H" & DataRow & ":J" & DataRow).Value = Application.Transpose(MyModel.Range("C120:C122"))
Next
This is a simple loop that finds the last row in "Data" and uses it for the loop defined in "Model".
The expected result of this is that the loop will begin at row 120 and continue until the last row in "Data", copying data from C120 through to C(lRow) and pasting it into the "Data" sheet.
Sub test()
' declare your variables so vba knows what it is working with
Dim lRow, i As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim srcws As Worksheet: Set srcws = wb.Worksheets("Data")
Dim destws As Worksheet: Set destws = wb.Worksheets("Model")
' find the last row in Data
lRow = srcws.Cells(srcws.Rows.Count, 1).End(xlUp).Row
' iterate from 120 to the last row found above
For i = 120 To lRow
' copy /paste the data
srcws.cells(1, 3).Copy Destination:=destws.cells(2, 7 + i)
Next i
End Sub
Best way is to use the cells-function, where the first argument is the row and the second is the column. Since you want to inrement the source to copy from by one row at a time but increment the paste destination by one column by a time, this method will be suitable.
In addition, try to not use "copy-paste", focus on setting the value for a cell by referring to a the value attribute from the source to copy. Each time you copy and then paste into the destination, you will need an additional memory cell, resulting in a much longer elapsed time if you are working with a large range to copy.
The code below should do the job.
Sub CopyData()
Dim i As Integer
i = 8 ' Start pasting into column H
' Loop until a blank cell is found
Do While Not Selection.Value = 0
With Sheets("Data").Cells(i + 112, 3)
' Select each cell in "Data", starting on C120
.Select
' Copy the value into "Model", starting on H2
Sheets("Model").Cells(2, i).Value = .Value
End With
Loop
End Sub
I am trying to write a macro that tidies up and interrogates raw data exported from some analytical instrumentation. I would like it to look through one column (sample names) down all rows and look for indicators of specific sample types e.g. duplicates. Finding these indicators I want to insert a row, and in the new inserted row do some simple calculations based on the two rows above. For now I will just be happy getting the row insertion to work.
I can get it to find the key word and insert 1 row, but it finds the first one and stops. There are multiple instances of these keywords in my data, and i want to insert a row below each
'original code - finds first keyword, inserts row and stops
Sub dup_finder()
Dim colHeader As Range
Set colHeader = Range("B1:B500")
Dim currCell As Range
Set currCell = Cells.Find("*_dup")
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
'my attempt to include loop - inserts 500 rows below keyword! stops
after first instance
Sub dup_finder()
Dim colHeader As Range
Dim row As Long
Dim currCell As Range
Set colHeader = Range("B1:B500")
Set currCell = Cells.Find("_dup")
For row = 1 To 500
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Next row
End Sub
I suggest always fully qualifying your ranges with the workbook and sheet.
You should be able to adapt this to what you want. You simply enter the range you want to check in, and the value you are checking for.
It works backwards, up through the range, inserting a row below each one it finds.
Sub InsertRows()
''Declare your variables
Dim RngToCheck As Range, ValToFind As String
''Set the range in which to look for your desired string.
Set RngToCheck = ThisWorkbook.Sheets("Sheet1").Range("B1:B500")
''Set what string to look for.
ValToFind = "_dup"
''Declare a variable to use as a counter
Dim i As Long
''Count backwards through each of the rows in the range.
''(If you went forwards through the range, the rows you
''are inserting would become part of that range and push
''the bottom rows (which you intended to check) out of the range).
For i = RngToCheck.Rows.Count To 1 Step -1
''Check if the last characters (the number of characters to
''check is defined by the length of the string we are looking
''for) of the current cell match the string we are looking for.
If Right(RngToCheck(i).Value, Len(ValToFind)) = ValToFind Then
''Insert the row (we need to offset by 1 row
''because rows are inserted ABOVE, and we
''want it BELOW the current cell).
RngToCheck(i).Offset(1, 0).EntireRow.Insert
''Now you can add your formulas to the new row...
''column A
RngToCheck(i).Offset(1, -1).Formula = "=1+1"
''column B
RngToCheck(i).Offset(1, 0).Formula = "=2+2"
''column C
RngToCheck(i).Offset(1, 1).Formula = "=A" & RngToCheck(i).Offset(1, 1).Row & "+B" & RngToCheck(i).Offset(1, 1).Row
''column D
RngToCheck(i).Offset(1, 2).Formula = "Hello"
''And so on...
End If
Next i
End Sub
Assuming you do want to insert a row under every instance of a cell in column B containing "_dup" this should work.
The problem with your code was that it wasn't looping and so only ever found one instance.
It's advisable not to specify a fixed range as you are inserting rows and the range will expand; however, you could do this and set the search direction as "previous".
Sub dup_finder()
Dim colHeader As Range, s As String
Set colHeader = Range("B1:B500") ' not actually used
Dim currCell As Range
'are we searching just B or the whole sheet?
Set currCell = Columns(2).Find(What:="_dup", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False) 'change parameters to suit
If Not currCell Is Nothing Then
s = currCell.Address 'store address of first found cell
Do
currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Set currCell = Columns(2).FindNext(currCell) 'find next case
Loop Until currCell.Address = s 'keep looping until we are back to the original case
End If
End Sub
New to VBA
I'm confused as to why I need to run my module twice to get it to update my cells. My code:
Option Explicit
Sub m_Range_End_Method()
Dim lRow As Long
Dim lCol As Long
Dim currentRow As Long
Dim i As Integer
Dim rng As Range
Set rng = ActiveCell
Range("B:B").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("MySheet").Select
' Loop Through Cells to set description in each cell
Do While rng.Value <> Empty
currentRow = ActiveCell.Row
If InStr(rng.Value, "PETROL") = 0 Then
Set rng = rng.Offset(1)
rng.Select
Else
Worksheets("MySheet").Cells(currentRow, 5) = "Shopping"
Worksheets("MySheet").Cells(currentRow, 6) = "Car"
Set rng = rng.Offset(1)
rng.Select
End If
Loop
End Sub
On the first run what happens in Excel 2016 is that Column B gets highlighted and that's it. I then have to press "Run" again in visual basics editor for it to then update all the entries at which point column B gets unselected. All I want to do is update the cells at the currentRow of a specified worksheet. I've been reading but have got myself into some confusion, someone said I should use the
Range("B:B").Select
statement and for some reason the spreadsheet update works but only if I run it twice. Without this Range command, for reasons I don't understand, the spreadsheet doesn't update - all that happens is that the box selection moves to entries with Petrol and stays there with the program running but not updating.
The aim of the program is to find in a sheet all occurrences of a word in column B, in this initial case that is PETROL (I'm going to expand to include many others). For that match on the same row I want it to update columns 5 and 6 with descriptions. The excel spreadsheet will have hundreds of rows of entries with varying descriptions in column B.
Any help would be much appreciated.
I guess you have to run it twice because the first time you run it, the ActiveCell could be anything, and your loop depends on it not being empty to start with, but after the first run you have selected column B (and other things)...
Read this previous answer on avoiding the use of Select and Activate, it will make your code more robust: How to avoid using Select in Excel VBA macros
Revised Code
See the comments for details, here is a cleaner version of your code which should work first time / every time!
Sub m_Range_End_Method()
Dim col As Range
Dim rng As Range
Dim currentRow As Long
' Use a With block to 'Fully Qualify' the ranges to MySheet
With ThisWorkbook.Sheets("MySheet")
' Set col range to the intersection of used range and column B
Set col = Intersect(.UsedRange, .Columns("B"))
' Loop through cells in col to set description in each row
For Each rng In col
currentRow = rng.Row
' Check upper case value match against upper case string
If InStr(UCase(rng.Value), "PETROL") > 0 Then
.Cells(currentRow, 5) = "Shopping"
.Cells(currentRow, 6) = "Car"
End If
Next rng
End With
End Sub
In reference to: Copy a row in excel if it matches a specific criteria into a new worksheet
I attempted applying the above hyperlink code to the needs of my own workbook. The only notable differences are: Object names, My data begins in "A2" instead of "A1", and my data is being copied to "L" column in a new worksheet instead of "A" column
Also... you can assume I have generated tabs in excel that correspond with each SelectCell.Value.
Sub Consolidate_Sheets()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Set MyRange = Sheets("Install_Input").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Call superSizeMe(MyCell, MyRange)
Sub superSizeMe(SelectCell As Range, SelectRange As Range)
Dim InstallInput As Worksheet
Dim strPasteToSheet As String
'New worksheet to paste into
Dim DestinationSheet As Worksheet
Dim DestinationRow As Range
'Define worksheet with input data
Set InstallInput = ThisWorkbook.Worksheets("Install_Input")
For Each SelectCell In SelectRange.Cells
InstallInput.Select
If SelectCell.Value <> "" Then
SelectCell.EntrieRow.Select ''''LOCATION OF RUN-TIME ERROR 438''''
Selection.Copy
Set DestinationSheet = Worksheets(SelectCell.Value)
Set DestinationRow = DestinationSheet.Range("L1:L" & DestinationSheet.Cells(Rows.Count, "L").End(xlUp).Row)
Range("L" & DestinationRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next SelectCell
InstallInput.Select
InstallInput.Cells(1, 1).Select
If IsObject(InstallInput) Then Set InstallInput = Nothing
If IsObject(SelectRange) Then Set SelectRange = Nothing
If IsObject(SelectCell) Then Set SelectCell = Nothing
If IsObject(DestinationSheet) Then Set DestinationSheet = Nothing
If IsObject(DestinationRow) Then Set DestinationRow = Nothing
End Sub
I am getting a Run-time error'438'
"Object doesn't support this property or method" on "SelectCell.EntireRow.Select"
Well your code has a typo
SelectCell.EntrieRow.Select
should say entire not Entrie. Personally I would use this method anyway, It selects the entire row based on the number you put in. FYI there is also a corresponding Columns().select if you need it in the future
sel_cell_row = SelectCell.Row
Rows(sel_cell_row).select
edit addressed to comment
The reason you get the 1004 error is like it says, the copy and paste areas don't match. Think of copying 10 rows, and trying to paste it into 2 rows, simply wouldn'y work. I'm guessing the problem actually stems from your destinationrows code. I'm not entirely sure what its trying to do, but here are two generic fixes
1)keep the copy code as it is, and modify the paste. Instead of selecting a range of cells to paste into, select the first cell (if your range was a1:a10, selecting a1 is sufficient) excel will then paste all the data starting at that first cell. so in your code do this
'comment out all this destination row stuff
'Set DestinationRow = DestinationSheet.Range("L1:L" & DestinationSheet.Cells(Rows.Count, "L").End(xlUp).Row)
'Range("L" & DestinationRow.Rows.Count + 1).Select
Range("L1").select 'only referencing the first cell to paste into
ActiveSheet.Paste
2)rather than selecting an entire row, why not select only the populated values in that row something like
sel_cell_row = SelectCell.Row
lastColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
range(Cells(sel_cell_row ,1),Cells(sel_cell_row ,lastColumn )).select
then do your copy as usual. the 1 is for column 1, or A. I'm assuming the data you want is in one row starting at column A and going till lastColumn. Maybe now this will match your destinationrows code.
3)Com,bine options 1 and 2. so copy only the populated cells, and paste to the first cell in the range