I am trying to split some cells into multiple rows. I currently am trying to break the cells up into column G (see pic below and) have all the same data in the lines below, with just the cells being split into multiple rows. Is this possible to be done?
Starting here:
and finishing with this:
If macro function is ok, here is sample code
Sub Split()
Dim meargedline As String
Dim rowNumber As Integer
rowNumber = 2
Dim splitData
For i = 2 To 4
meargedline = Cells(i, 3)
splitData = VBA.Split(meargedline, Chr(10))
For j = LBound(splitData, 1) To UBound(splitData, 1)
Cells(j + rowNumber, 4) = Cells(i, 1)
Cells(j + rowNumber, 5) = Cells(i, 2)
Cells(j + rowNumber, 6) = splitData(j)
Next j
rowNumber = rowNumber + UBound(splitData, 1) + 1
Next i
This will do a basic loop through and generate an output. Note the constants and make sure you specify for your workbook. You can see an example of it here.
Sub runSplitter()
Const topRightCellAddress = "E20"
Const startCellToSetValues = "A1" 'where new rows will be placed
Const sheetOneName = "Start" 'make sure these match"
Const sheetTwoName = "Output"
Const codeOfLineSplitter = 10 'asci code line splitter
Dim firstSheet As Worksheet, secondSheet As Worksheet
Set firstSheet = Sheets(sheetOneName)
Set secondSheet = Sheets(sheetTwoName)
Dim aCell As Range
Set aCell = firstSheet.Range(topRightCellAddress)
Dim aRR() As String
Dim r As Long
Do While Not IsEmpty(aCell)
aRR = Split(aCell.Value2, Chr(codeOfLineSplitter), -1)
Dim i As Long
With secondSheet.Range(startCellToSetValues)
For i = LBound(aRR) To UBound(aRR)
.Offset(r, 0).Value2 = aCell.Offset(0, -2).Value2
.Offset(r, 1).Value2 = aCell.Offset(0, -1).Value2
.Offset(r, 2).Value2 = aRR(i)
r = r + 1
Next i
End With
Set aCell = aCell.Offset(1, 0)
Loop
End Sub
you can use power query to achieve the target you want. Click here for reference https://www.youtube.com/watch?v=wJ6y2anloW4.
Related
My loop seems to create infinite rows and is bugging
For Each Cell In Workbooks(newBook).Sheets(1).Range("A1:A" & lRow)
Checker = Cell.Value
For Counter = 1 To Len(Checker)
If Mid(Checker, Counter, 1) = vbLf Then
holder = Right(Mid(Checker, Counter, Len(Checker)), Len(Checker))
Workbooks(newBook).Sheets(1).Range(Cell.Address).EntireRow.Insert
End If
Next
Next Cell
Use a reverse loop. For i = lRow to 1 Step -1. Also to separate word, you can use SPLIT().
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim Ar As Variant
'~~> Change this to the relevant worksheet
Set ws = Sheet2
With ws
'~~> Find last row in Column A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Reverse Loop in Column A
For i = lRow To 1 Step -1
'~~> Check if cell has vbLf
If InStr(1, .Cells(i, 1).Value, vbLf) Then
'~~> Split cell contents
Ar = Split(.Cells(i, 1).Value, vbLf)
'~~> Loop through the array from 2nd position
For j = LBound(Ar) + 1 To UBound(Ar)
.Rows(i + 1).Insert
.Cells(i + 1, 1).Value = Ar(j)
Next j
'~~> Replace cells contents with content from array from 1st position
.Cells(i, 1).Value = Ar(LBound(Ar))
End If
Next i
End With
End Sub
BEFORE
AFTER
This is my solution, works with 2 dimensional ranges as well and it works on Selection, so select the range with the cells you want to split and run the code.
Sub splitByNewLine()
Dim pasteCell As Range, rowCumulationTotal As Integer
rowCumulationTotal = 0
Dim arr() As Variant
arr = Selection
Selection.Clear
For i = 1 To UBound(arr)
Dim rowCumulationCurrent As Integer, maxElemsOnRow As Integer
rowCumulationCurrent = 0
maxElemsOnRow = 0
For j = 1 To UBound(arr, 2)
Dim elems() As String, elemCount As Integer
elems = Split(arr(i, j), vbLf)
elemCount = UBound(elems)
For k = 0 To elemCount
Cells(Selection.Row + i + rowCumulationTotal + k - 1, Selection.Column + j - 1) = elems(k)
If maxElemsOnRow < k Then
rowCumulationCurrent = rowCumulationCurrent + 1
maxElemsOnRow = k
End If
Next k
Next j
rowCumulationTotal = rowCumulationTotal + rowCumulationCurrent
Next i
Exit Sub
End Sub
Input:
Output:
I need to pass the variables max, min, and their respective locations to another sub where it will format each max and min in their respective column. I am trying to create an array that will store the locations and the values but its not working.
I was told to first identify the number of columns used and the number of rows, which is the beginning.
Rows = wsData.UsedRange.Rows.Count
Columns = wsData.UsedRange.Col.Count
j = 1
ReDim Min(j)
With wsData.Range("A3:A19")
For j = 1 To 19 'colum
Min(j) = WorksheetFunction.Min(Range(.Offset(1, j), .Offset(Row, j)))
Max = WorksheetFunction.Max(Range(.Offset(1, j), .Offset(Row, j)))
Min(j) = Min
j = j + 1
ReDim Preserve Min(j) 'saves variables
Next 'next column
End With
The code below uses the ActiveSheet which you need to change to reference the worksheet for your data. Additionally, it assumes that your data starts with Row 1. The code looks at each column in the range and stores the minimum/maximum (it does not account for multiple cells which may share the min or max value) value found in the column as well as the cell's address, in an array and then passes the array to two different subs, one which simply displays the information in a message and one which formats the the background color of the cells. This code does not perform any kind of error handling, but should get you where you want to go.
the line Option Explicit requires that all of the variables be defined using a Dim statement
the line Option Base 1 makes the default starting point for arrays 1 instead of 0
Option Explicit
Option Base 1
Sub GatherData()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim iMin() As Variant
Dim iMax() As Variant
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
ReDim iMin(iCols, 2)
ReDim iMax(iCols, 2)
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMin(j, 1) = R.Value
iMin(j, 2) = R.Address
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMax(j, 1) = R.Value
iMax(j, 2) = R.Address
Next j
ListMinMax iMax(), True
ListMinMax iMin(), False
FormatMinMax iMax, "green"
FormatMinMax iMin, "yellow"
Set R = Nothing
End Sub
Sub ListMinMax(ByRef Arr() As Variant, ByVal MinMax As Boolean)
Dim strOutput As String
Dim i As Long
If MinMax = True Then
strOutput = "Maximums:" & vbCrLf & vbCrLf
Else
strOutput = "Minimums:" & vbCrLf & vbCrLf
End If
For i = 1 To UBound(Arr, 1)
strOutput = strOutput & "Cell: " & Arr(i, 2) & " = " & Arr(i, 1) & vbCrLf
Next i
MsgBox strOutput, vbOKOnly
End Sub
Sub FormatMinMax(ByRef Arr() As Variant, ByVal BGColor As String)
Dim i As Long
Select Case UCase(BGColor)
Case "GREEN"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbGreen
Next i
Case "YELLOW"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbYellow
Next i
Case Else
MsgBox "Invalid Option", vbCritical
End Select
End Sub
======================================================================
The code below does away with the need for the arrays and formats the color of the min/max values as it finds them
Sub GatherData2()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbYellow
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbGreen
Next j
Set R = Nothing
End Sub
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
I have the Code that copies the values and gives me the values but not the one that i Need. I feel that I am Close but something is missing. The Code copies the whole worksheet of the workbook and i Need the values that meet the criterias.
I have this main workbookand i want to take Information from different workbooks which have the same Format, for example this and I want, in the main workbook, to paste the values in some range based on the criterias in the first three columns ("SSL";"Baureihe";"Produktionsjahr")
this is the Code that i have done till now
Sub Transfer ()
Dim SSl As String
Dim Baureihe As String
Dim Produktionsjahr As String
Dim fileName As String
Dim Tfile As Workbook
Dim shData As Worksheet, shOutput As Worksheet
Dim rg As Range, ra As Range
Dim i As Long, row As Long, j As Long
Set shData = ThisWorkbook.Worksheets("Transponieren")
filename = Application.getOpenFilename("Excel file (*.xlsm),*.xlsm", , "Select File")
If filename = Empty then
Exit Sub
End If
Set Tfile = Application.Workbooks.Open(filename)
Set shOutput = Tfile.Worksheets("Transponieren")
Set rg = shData.Range("A1").CurrentRegion
Set ra = shOutput.range("A1").CurrentRegion
row = 2
For i = 2 To rg.Rows.Count
SSL = Sheets("Transponieren").Cells(i, 1).Value
Baureihe = Sheets("Transponieren").Cells (i , 2).Value
Produktionsjahr = Sheets("Transponieren") .Cells(i, 3).Value
For j = 2 To ra.Rows.Count
If ra.Cells(j, 1).Value = SSL And _
ra.Cells(j, 2).Value = Baureihe And _
ra.Cells(j, 3).Value = Produktionsjahr Then
Tfile.Sheets("Transponieren").Range("A" & i & ":E" & i).Copy _
Destination:=ThisWorkbook.Sheets("Transponieren").Range("K" & j & ":O" & j)
row = row + 1
Application.CutCopyMode = False
End if
Next j
Next i
End Sub
I am new at vba Excel, i tried various way but i can't seem to see why this Code doesn't copy only the values that i need. Thanks in Advance
This is the Code that helped me finish my taks. Just if someone needed.
Option Explicit
Sub transfer()
Dim fileName As Variant, a() As Variant, b() As Variant, c As Variant, i As Long, j As Long
Dim sh1 As Worksheet, wb2 As Workbook, sh2 As Worksheet
'
Application.ScreenUpdating = False
Set sh1 = Sheets("Transponieren")
fileName = Application.GetOpenFilename("Excel file (*.xlsx),*.xlsx", , "Select File")
If fileName = False Then Exit Sub
Set wb2 = Application.Workbooks.Open(fileName)
Set sh2 = wb2.Sheets("Transponieren")
`
a = sh1.Range("A2:C" & sh1.Range("A" & Rows.Count).End(xlUp).row)
b = sh2.Range("A2:E" & sh2.Range("A" & Rows.Count).End(xlUp).row)
ReDim c(1 To UBound(a), 1 To 5)
For i = 1 To UBound(a)
For j = 1 To UBound(b)
If a(i, 1) = b(j, 1) And a(i, 2) = b(j, 2) And a(i, 3) = b(j, 3) Then
c(i, 1) = b(j, 1)
c(i, 2) = b(j, 2)
c(i, 3) = b(j, 3)
c(i, 4) = b(j, 4)
c(i, 5) = b(j, 5)
Exit For
End If
Next
Next
wb2.Close False
sh1.Range("K2").Resize(UBound(a), 5).Value = c
End Sub
I have a task to restructure a two column excel sheet and expand it. Here is a picture to show what needs to be done, the data on the left of the green column is the original data and the data on the right is how it should look, but its only done for the first entry, I need to replicate it for all 10,000 rows of data.
To explain more indepth, each CRD it needs to be expanded to 160 rows, and go from 1978->2018 while listing the quarters out for each year. What is the best approach? Is it possible to write a macro to solve this ?
The following expects Sheet1 ans Sheet2 to be the names. And goes for 158 quarters.
Option Explicit
Sub doFromThru()
' clear contents
Sheets("Sheet2").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Cells(1, "A") = "CRD"
Cells(1, "B") = "Year"
Cells(1, "C") = "Quarter"
Cells(1, "D") = "QuarterNumerical"
Cells(1, "E") = "Disclosure"
Dim nOutRow As Integer
nOutRow = 1
' step thru all the rows on the input sheet
Dim nInRow As Long, maxInRow As Long, nInCRD As String, nInDisc As String
maxInRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For nInRow = 2 To maxInRow
nInCRD = Sheets("Sheet1").Cells(nInRow, "A")
nInDisc = Sheets("Sheet1").Cells(nInRow, "L")
' create the new rows on Sheet2
Dim dFrom As String, nQtr As Integer
dFrom = DateValue("Oct 1978") ' starting from here
For nQtr = 1 To 158
nOutRow = nOutRow + 1
Sheets("Sheet2").Cells(nOutRow, "A") = nInCRD
Sheets("Sheet2").Cells(nOutRow, "B") = Format$(dFrom, "yyyy")
Sheets("Sheet2").Cells(nOutRow, "C") = Format$(dFrom, "Q")
Sheets("Sheet2").Cells(nOutRow, "D") = nQtr
Sheets("Sheet2").Cells(nOutRow, "E") = nInDisc
dFrom = DateAdd("Q", 1, dFrom)
Next nQtr
Next nInRow
End Sub
Add some diagnostics to tell you more. After nOutRow = nOutRow + 1
Sheets("Sheet2").Cells(1, "G") = nInRow
Sheets("Sheet2").Cells(1, "H") = nOutRow
Sheets("Sheet2").Cells(1, "I") = nQtr
Sheets("Sheet2").Cells(1, "J") = nInDisc
Untested.
Code assumes you want to start from Q4 of the year 1978 and will loop
for 159 quarters after 1978 Q4. (If necessary, you can change this by changing the value of TOTAL_QUARTERS and START_QUARTER in the code)
You will need to change "Sheet1" in the code to whatever the name of your sheet is.
Code tries to overwrite the contents of columns CH to CL on said sheet. So you might want to save a copy of your workbook before running.
Code:
Option Explicit
Sub ExpandRows()
Const START_YEAR as long = 1978
Const START_QUARTER as long = 4
Const TOTAL_QUARTERS as long = 160
With thisworkbook.worksheets("Sheet1")
Dim lastRow as long
lastRow = .cells(.rows.count, "A").row
Dim inputCRD() as variant
inputCRD = .range("A2:A" & lastRow).value2
Dim inputDisclosure() as variant
inputDisclosure = .range("L2:L" & lastRow).value2
Dim yearOffset as long
Dim quarterIndex as long
Dim numericalQuarterIndex as long
Dim totalRowCount as long
totalRowCount = (lastRow - 1) * TOTAL_QUARTERS ' -1 to skip first row
Dim outputArray() as variant
Redim outputArray(1 to totalRowCount, 1 to 5)
Dim readIndex as long
Dim writeIndex as long
For readIndex = lbound(inputCRD,1) to ubound (inputCRD,1)
quarterIndex = START_QUARTER
For numericalQuarterIndex = 1 to TOTAL_QUARTERS
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = inputCRD(readIndex, 1)
outputArray(writeIndex, 2) = START_YEAR + yearOffset
outputArray(writeIndex, 3) = quarterIndex
outputArray(writeIndex, 4) = numericalQuarterIndex
outputArray(writeIndex, 5) = inputDisclosure(readIndex, 1)
If quarterIndex < 4 then
quarterIndex = quarterIndex + 1
Else
yearOffset = yearOffset + 1
quarterIndex = 1
End if
Next numericalQuarterIndex
Next readIndex
.range("CH2").resize(ubound(outputArray,1), ubound(outputArray,2)).value2 = outputArray
End with
End sub