I have Excel data that looks like the top two rows of the following:
I need to get it looking like the data on the bottom rows.
A very easy way of doing this is by using the transpose option of Paste Special, depending on how much data you have. For a small amount it's worth doing it this way.
Select B1:E1
Copy.
Select where you want it pasted.
Go to Edit, Paste Special and choose transpose
It will now be shown vertically. Just fill in the name Joe Bloggs and fill it down.
If you have a lot of different people, Joe Bloggs, Jane Doe and many more it would be a chore to transpose each individual person so a quick bit of VB code like horrible thing below should do the trick.
Public Sub test()
Dim rowFound As Boolean, columnFound As Boolean, y As Long, x As Long, rowCounter As Long
Dim thisSheet As Excel.Worksheet, resultSheet As Excel.Worksheet
Set thisSheet = ActiveWorkbook.Sheets("Sheet1")
Set resultSheet = ActiveWorkbook.Sheets("Sheet2")
rowFound = True
y = 0
rowCounter = 0
Do While rowFound
columnFound = True
Dim foundName As String
foundName = thisSheet.Range("A1").Offset(y).Value
If foundName = "" Then
rowFound = False
Else
x = 0
Do While columnFound
If thisSheet.Range("B1").Offset(y, x).Value = "" Then
columnFound = False
Else
resultSheet.Range("A1").Offset(rowCounter).Value = foundName
resultSheet.Range("B1").Offset(rowCounter).Value = thisSheet.Range("B1").Offset(y, x).Value
rowCounter = rowCounter + 1
End If
x = x + 1
Loop
End If
y = y + 1
Loop
End Sub
x and y are used like a set of graph coordinates. For every row it scans through the columns in the row, and adds it to the list below.
Edit:
I've updated the code, Integers are now Long and it writes the results to sheet2.
Related
We are trying this trick for a while !
We have a range of 'x' rows, and we would like to make a random sample of 35 rows by hiding all others.
The difficult mission for us is to make all random row unique (to avoid hiding a row already hide).
For that, we tried to make a loop, with a check if the row is already hide.
We tried to make this code, but it's not working :
Function randSample(Rg As Range) As Range
Set randSample = Rg.Rows(Int(Rnd * Rg.Rows.Count) + 1)
End Function
Sub sampling()
Dim N As Long, i As Integer, Raw As Range, myRange As Range, sampleRangeCount As Long
N = Cells(12, 1).End(xlDown).Row
Set myRange = Range("A12:AW" & N)
sampleRangeCount = myRange.Rows.Count - 35
Application.ScreenUpdating = False
Randomize
For i = 1 To sampleRangeCount
Do
Set Raw = randSample(myRange)
Loop Until Raw.EntireRow.Hidden = False
Raw.EntireRow.Hidden = True
Next
Application.ScreenUpdating = True
End Sub
Could you help us for that? Where are we wrong?
Thank you a lot!
Kevin
Would like to ask if it is possible to create a condition in excel vba for inserting rows of matched values in output file
for example:
This is an example list of my student:
This one is for the checklist of their exams / questionnaires:
This would be the final output:
Is it possible for VBA to look like in the results file? I only figured out how to put the number series per TestLEVEL value. But still thinking how to insert the Questionnaire and Value columns exactly the way I want.
THANKS! hope it is possible
Upon further reflection, and assuming I have understood your requirements correctly, I think the easiest way to do this is by using the FILTER-function. Note that this function is only available in Office 365, and that your argument separator might be a different one than mine.
It is also not ideal for automating the task since I assume the number of Questionnaire / Value pairs will be different from time to time. It is fairly simple to use though, so I guess it won't be a lot of work to create the formulas.
The way I did it was creating a duplicate of the second sheet you have a picture of into my workbook, and then create a sheet similar to the third one you have a picture of. In this sheet I put the formula
=FILTER(Sheet1!$C$2:$C$19;Sheet1!$A$2:$A$19=D2;NA())
into cell F2 and
=FILTER(Sheet1!$D$2:$D$19;Sheet1!$A$2:$A$19=D2;NA())
into G2.
The formula then fills the filtered range into the column as shown below:
To get the Questionnaire values of the student with student no. 4321 into range F8:F13, use the formula
=FILTER(Sheet1!$C$2:$C$19;Sheet1!$A$2:$A$19=D8;NA())
and so on.
I think this should solve your problem as presented in the question, at least, though your sheet will probably need a bit of editing if you have different input data.
As a further tip, I would recommend changing your data to tables when that is what they basically are anyway, it makes referencing them a bit simpler.
I hope this was of some help to you, don't hesitate to ask if something seems unclear.
Use Find and FindNext to match the Student No and Test Levels on the 2 sheets.
Option Explicit
Sub MyMacro()
Dim wb As Workbook
Dim wsName As Worksheet, wsExam As Worksheet, wsOut As Worksheet
Dim rng As Range, rngNo As Range
Dim iLastRow As Long, r As Long, rOut As Long
Dim n As Integer, m As Integer, i As Long
Dim sNo As String, sTest As String, sFirstFind As String
Set wb = ThisWorkbook
Set wsName = wb.Sheets("Sheet1")
Set wsExam = wb.Sheets("Sheet2")
Set rngNo = wsExam.UsedRange.Columns("A:A") ' student no
Set wsOut = wb.Sheets("Sheet3")
wsOut.Cells.Clear
i = 1 ' col A no
n = 0 ' block row for Col B-F
m = 0 ' block row for Col G-H
rOut = 2
iLastRow = wsName.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To iLastRow
sTest = wsName.Cells(r, "D")
sNo = wsName.Cells(r, "C")
' start new block if no or test different to previous row
If sNo <> wsName.Cells(r - 1, "C") _
Or sTest <> wsName.Cells(r - 1, "D") Then
' align columns
If m > n Then
rOut = rOut + m
Else
rOut = rOut + n
End If
n = 0
m = 0
' start new test
sTest = wsName.Cells(r, "D")
If sTest <> wsName.Cells(r - 1, "D") Then
wsOut.Cells(rOut, "A") = i
i = i + 1
End If
' search for matching Student No
Set rng = rngNo.Find(sNo, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
Else
sFirstFind = rng.Address
Do
'is testlevel the same
If rng.Offset(0, 4) = sTest Then
' copy col C-D to G-H
rng.Offset(0, 2).Resize(1, 2).Copy wsOut.Cells(rOut + m, "G")
m = m + 1
End If
' find next
Set rng = rngNo.FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> sFirstFind
End If
End If
' copy col A-E to col B-F
wsName.Cells(r, "A").Resize(1, 5).Copy wsOut.Cells(rOut + n, "B")
n = n + 1
Next
MsgBox "Done", vbInformation
End Sub
Before I start, I just want to thank every contributor ahead of time. I've only posted one question before, and I was amazed at how quickly I got responses and how much I learned after studying the solution. I'm hoping I will have enough reputation points soon to start upvoting good solutions I find here.
Anyways, what I'm trying to do is return one number, and that number is the maximum number of names that appear in a single cell of a worksheet column. Each cell in that column can have any number of names in it. Each name is delimited by a pipe "|", so I count the pipes and then add one to get the number of names in each cell. For example: Cell value is "Bob | Jon | Larry" = 2pipes +1 = 3 names.
My code below works, but I need to do this on tens of thousands of records. I don't think my solution is a good or efficient way to do it (tell me if I'm wrong). So my questions are:
Is there a better way to accomplish this, such as without looping through every cell in the range?
If there isn't a totally different approach to this, how can I avoid actually printing the name counts in cells in a new column? Could I store these values in an array and calculate the max of the array? (maybe there is already a thread on this topic you could point me to?)
Sub charCnt()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = Worksheets("Leasing")
Dim vRange As Variant
Dim iCharCnt As Integer
Dim iRows As Integer
Dim i As Integer
Dim iMax As Integer
Const sFindChar As String = "|"
iRows = ws.Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows
For i = 1 To iRows
vRange = Cells(i, "O") 'column O has the names
iCharCnt = Len(vRange) - Len(Replace(vRange, sFindChar, "")) 'find number of | in single cell.
ws.Cells(i, "W") = iCharCnt 'column W is an empty column I use to store the name counts
Next i
iMax = Application.WorksheetFunction.Max(Range("W:W")) + 1 'return max from column W
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
Max Number of Substrings
Option Explicit
Sub charCount()
Const cCol As String = "O"
Const fRow As Long = 1
Const Delimiter As String = "|"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Leasing")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
Dim rg As Range: Set rg = ws.Cells(fRow, cCol).Resize(lRow - fRow + 1)
Dim Data As Variant: Data = rg.Value
Dim i As Long
For i = 1 To UBound(Data, 1)
Data(i, 1) = Len(Data(i, 1)) - Len(Replace(Data(i, 1), Delimiter, ""))
Next i
Dim iMax As Long: iMax = Application.Max(Data) + 1
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
A close-to-formula approach
Combining worksheet functions CountA() and FilterXML() allows to get all substring counts separated by the pipe character |:
Sub CountSubstrings(StartCell As Range, TargetRng As Range)
'Purp.: count items separated by pipes
'Meth.: via worksheetfunction FILTERXML()
'Note: assumes target in same sheet as StartCell (could be changed easily)
'a) enter formula into entire target range
Const PATTERN$ = _
"=IF(LEN($),COUNTA(FILTERXML(""<t><s>""&SUBSTITUTE($,""|"",""</s><s>"")&""</s></t>"",""//s"")),0)"
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Parent.Name & "!" & StartCell.Address(False, False))
'b) optional overwriting of formulae
'TargetRng = TargetRng.Value
'c) display maximum result
MsgBox Application.Max(TargetRng)
End Sub
Hint: You can even shorten code as follows if you want to include the fully qualified workbook + worksheet reference in the formula assignment. Just use the additional argument External:=True in .Address (resulting e.g. in something like '[Test.xlsm]Sheet1'!A2):
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Address(False, False, External:=True))
Possible Example call
With Sheet1
CountSubstrings .Range("A2"), .Range("D2:D5")
End With
Further link
C.f. JvdV's encyclopaedia-like site demonstrating the various possibilities to use FilterXML()
Brilliant answer by VBasic2008. I thought I would look at it purely as a coding exercise for myself. Alternative below provided for interest only.
Option Explicit
Sub CountMaxNames()
Dim arr1(), i, j, count As Long, tally As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("leasing")
arr1 = ws.Range("O1:O" & ws.Range("O" & Rows.count).End(xlUp).Row)
count = 0: tally = 0
For Each i In arr1
For j = 1 To Len(i)
If Mid(i, j, 1) = "|" Then count = count + 1
Next j
count = count + 1
If count >= tally Then tally = count
count = 0
Next i
MsgBox "Maximum number of names in one cell is " & tally
End Sub
As you can see above, I have a table in a Excel sheet where indication A can have product 1, product 2 and so forth (The prods names are all different depending on the indication, this is just for simplicity!).
In my userform a similar format is presented. I want to basically match the indication name on my excel sheet with the indication name in my userform. If they match, then Product 11 gets A's Prod 1 name, Product 12 gets A's Prod 2 name and so forth.
I've tried the following, but I'm just starting using VBA so I'm sure it probably doesn't even make sense.
Dim code_ind As String
Dim sel_ind As String
Dim chkbx As Control
Dim labx As Control
Dim i As Integer
Dim col_value As Integer
Dim row_value As Integer
For i = 1 To 8
For j = 1 To 4
For row_value = 4 To 11
col_value = 0
Set chkbx = Me.Controls("seg_l_selInd_" & i)
Set labx = Me.Controls("seg_cb_selInd_" & i & j)
sel_ind = tWb.Worksheets("LALALA").Columns(2).Find(what:=chkbx)
If code_ind = sel_ind Then
labx.Name = tWb.Worksheets("LALALA").Cells(row_value, 3 + col_value)
col_value = col_value + 1
End If
Next row_value
Next j
Next i
Is there any way I can do this? I know I could just write the names manually, but I need my tool to be as flexible as possible. Ideally, if more information is added into the excel table, the userform will automatically update.
Please check the next way. I tried thinking your project in this way:
The form in the next example must be named frmChkBox. The check boxes on the form will have names like "CheckBox11", "CheckBox12" and so on, first digit after "CheckBox" string being the row and the next one the column. If you appreciate that your real situation will exceed one digit number for the row number, they can be separated by "_", or something else. You can also create the check boxes on the flay.
a. Please paste in the form code module the next code lines:
Option Explicit
Private ChkBColl As New Collection
Private ChkB() As New ChkBoxChClss
Private Sub UserForm_Initialize()
Dim ws As Worksheet, rng As Range, iRow As Long, iCol As Long
Dim ctrl As MSForms.Control, ext As String, arrUsed, k As Long
ReDim ChkB(32)
ReDim arrUsed(Me.Controls.count)
Set ws = Sheets("INDICATION-PRODUCT")
Set rng = ws.Range("B2:E9")
For iRow = 1 To 8
For iCol = 1 To 4
For Each ctrl In Me.Controls
If TypeOf ctrl Is MSForms.CheckBox Then
If IsError(Application.Match(ctrl.Caption, arrUsed, 0)) Then
ext = Right(ctrl.Caption, Len(ctrl.Caption) - 8)
If left(ext, 1) = iRow And Right(ext, 1) = iCol Then
ctrl.Tag = rng.cells(iRow, iCol).Address
ctrl.Caption = rng.cells(iRow, iCol).Value
arrUsed(k) = ctrl.Caption: k = k + 1
ChkBColl.Add ctrl, ctrl.Name
Set ChkB(k).chkBEvent = ctrl
End If
End If
End If
Next
Next iCol
Next iRow
End Sub
Public Sub DoSomething(chk As MSForms.CheckBox)
Dim ws As Worksheet
Set ws = Sheets("INDICATION-PRODUCT"): ws.Activate
If chk.Value = True Then
ws.Range(chk.Tag).Select 'do whatever needed with the cell...
Else
ws.Range("A1").Select
End If
End Sub
Each check box Tag will receive the associated cell address.
In order to automatically allocate the same event to all of them, a simple class wrapper (named `ChkBoxChClss') will be created. It will identify the clicked check box and send the object to a form sub, where to be processed as needed. Please, paste the next code in the class:
Option Explicit
Public WithEvents chkBEvent As MSForms.CheckBox
Private Sub chkBEvent_Change()
frmChkBox.DoSomething chkBEvent
End Sub
You can use the Public Sub DoSomething to deal with the check box being clicked. Now, clicking a check box, if its value is True the correspondent cell will be selected. If False, the "A1" cell will be selected. You can do whatever you need.
I was finally able to solve it!
The table I have on my worksheet (Image 1) has the indication column that corresponds to the indication values on my userform. For each indication, there are several products.
I want my tool to be as flexible as possible, so I needed to match the indication name and for each checkbox in my userform I would obtain it's name from the table.
For example: Indication A, Prod 1 = Prod 1 (Checkbox.Name = Cell(x,y))
This is the code that I'm using:
Dim code_ind As String
Dim sel_ind As String
Dim chkbx As Control
Dim labx As Control
Dim i As Integer
Dim j As Integer
Dim col_value As Integer
Dim row_value As Integer
For i = 1 To 8
Set chkbx = Me.Controls("seg_l_selInd_" & i)
sel_ind = tWb.Worksheets("INDICATION-PRODUCT").Columns(2).Find(what:=chkbx)
If chkbx = sel_ind Then
col_value = 0
While tWb.Worksheets("INDICATION-PRODUCT").Cells(i + 3, 3 + col_value) <> ""
For j = 1 To 4
Set labx = Me.Controls("seg_cb_selInd_" & i & j)
labx.Caption = tWb.Worksheets("INDICATION-PRODUCT").Cells(i + 3, 3 + col_value)
col_value = col_value + 1
Next j
Wend
End If
Next i
Does it make sense to you?
Is there any way to make my code more flexible? For example, I'm assuming there are 8 indications (i = 1 to 8), but realistically there could be more in the future.
I have a little experience with VBA, and I would really appreciate any help with this issue. In a basic sense, I need to convert 2 columns of data in sheet 1 to rows of data in sheet 2.
It currently looks like this in Excel:
And I need it to look like this:
I've already written the code to transfer the headings over to sheet 2, and it works fine. I'm just having issues with transferring the actual values in the correct format. Right now, the body of my code is
ws.Range("B3").Copy
ws2.Range("C2").PasteSpecial xlPasteValues
ws.Range("B4").Copy
ws2.Range("D2").PasteSpecial xlPasteValues
ws.Range("B5").Copy
ws2.Range("E2").PasteSpecial xlPasteValues
ws.Range("B6").Copy
ws2.Range("F2").PasteSpecial xlPasteValues
continued on and on. However, this really won't work, as the actual document I'm working on has tens of thousands of data points. I know there's a way to automate this process, but everything I've tried has either done nothing or given an error 1004.
Any help with this would be greatly appreciated!!
Edit: There are hundreds of little sections of data, each 18 rows long (1 row for the frame #, 1 row for the time, and 1 row for each of the 16 channels). I'm trying to get it into a loop with a step size of 18. Is that possible? I'm fine with loops, but I've never done a loop with copying and pasting cell values
Try this code:
Dim X() As Variant
Dim Y() As Variant
X = ActiveSheet.Range("YourRange").Value
Y = Application.WorksheetFunction.Transpose(X)
Also check out this link: Transpose a range in VBA
This method leverages loops and arrays to transfer the data. It isn't the most dynamic method but it gets the job done. All the loops use existing constants, so if your data set changes you can adjust the constants and it should run just fine. Make sure to adjust the worksheet names to match the names you are using in your excel document. In effect, what this is doing is loading your data into an array and transposing it onto another worksheet.
If your data set sizes change quite a bit, you will want to include some logic to adjust the loop variables and array size declarations. If this is the case, let me know and I'll figure out how to do that and post an edit.
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const dataSetSize = 15
Const row15Start = 3
Const row15End = 18
Const row30Start = 21
Const row30End = 36
Const colStart = 2
Const destColStart = 2
Const dest15RowStart = 2
Const dest30RowStart = 3
Dim time15Array() As Integer
Dim time30Array() As Integer
ReDim time15Array(0 To dataSetSize)
ReDim time30Array(0 To dataSetSize)
Dim X As Integer
Dim Y As Integer
Dim c As Integer
c = 0
For X = row15Start To row15End
time15Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
c = 0
For X = row30Start To row30End
time30Array(c) = source.Cells(X, colStart).Value
c = c + 1
Next X
For X = 0 To dataSetSize
dest.Cells(dest15RowStart, X + destColStart).Value = time15Array(X)
Next X
For X = 0 To dataSetSize
dest.Cells(dest30RowStart, X + destColStart).Value = time30Array(X)
Next X
End Sub
EDIT-> I think this is what you are looking for after reading your edits
Sub moveTimeData()
Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")
Const numberDataGroups = 4
Const dataSetSize = 15
Const stepSize = 18
Const sourceRowStart = 3
Const sourceColStart = 2
Const destColStart = 2
Const destRowStart = 2
Dim X As Integer
Dim Y As Integer
Dim currentRow As Integer
currentRow = destRowStart
For X = 0 To numberDataGroups
For Y = 0 To dataSetSize
dest.Cells(currentRow, Y + destColStart).Value = source.Cells((X * stepSize) + (Y + sourceRowStart), sourceColStart)
Next Y
currentRow = currentRow + 1
Next X
End Sub
Now the key to this working is knowing how many groups of data you are dealing with after the data dump. You either need to include logic for detecting that or adjust the constant called numberDataGroups to reflect how many groups you have. Note: I leveraged a similar technique for traversing arrays that have their data stored in Row Major format.
Use Copy, then Paste Special+Transpose to turn your columns into rows:
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
Try this:
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2")
InRange.Worksheet.Activate
InRange.Select
Selection.Copy
OutRange.Worksheet.Activate
OutRange.Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End Sub
This is a way to do it using a loop, here illustrated with a step of 2
Notice that you have to specify the OutRange precisely the correct size (here NTR2 is the 10001's cell of the 2nd row).
Sub TansposeRange()
Dim InRange As Range
Dim OutRange As Range
Dim i As Long
Set InRange = Sheet1.Range("B3:B10002")
Set OutRange = Sheet2.Range("C2:NTR2")
For i = 1 To 10000 Step 2
OutRange.Cells(1, i) = InRange.Cells(i, 1)
Next i
End Sub
'The following code is working OK
Sub TansposeRange()
'
' Transpose Macro
'
Dim wSht1 As Worksheet
Dim rng1 As Range
Dim straddress As String
Set wSht1 = ActiveSheet
On Error Resume Next
Set rng1 = Application.InputBox(Prompt:="Select Columns or Rows to transpose", _
Title:="TRANSPOSE", Type:=8)
If rng1 Is Nothing Then
MsgBox ("User cancelled!")
Exit Sub
End If
straddress = InputBox(Prompt:="Full cell Address as Sheet2!A1", _
Title:="ENTER Full Address", Default:="Sheet1!A1")
If straddress = vbNullString Then
MsgBox ("User cancelled!")
Exit Sub
End If
Application.ScreenUpdating = False
rng1.Select
rng1.Copy
On Error GoTo 0
'MsgBox straddress
Range(straddress).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.ScreenUpdating = True
End Sub