Posts by michaelnicolas
-
-
-
-
Re: Transpose data with key in the first column, merge dupes and write to other shee
Try (it works on your sample data).
You need to change the worksheet names ("Sheet1","Sheet2") to your actual sheet name.
Per sample data, assumes that your data start from range A1, and item in Col.A, desc in Col.B, RM in Col.C, QTY in Col.K.Code
Display MoreSub TranspData() Dim wsData As Worksheet, wsOutput As Worksheet Dim rngItems As Range, rngRM As Range, rngCell As Range, rngAreas As Range Dim aOut() As Variant Dim dItems() As String Dim LastRow As Long, cItems As Long, cRM As Long, tempRM As Long, Index As Long, i As Long, aCols As Long Dim iHeader As Long, n As Long, iInfo As Long, x As Long, AreaRows As Long, iAreas As Long, y As Long Set wsData = Worksheets("Sheet1") 'adjust "Sheet1" to actual name Set wsOutput = Worksheets("Sheet2") 'adjust "Sheet1" to actual name LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row i = 1: n = 1: x = 2: y = 1 Application.ScreenUpdating = False 'Load unique item values into dItems() array With wsData .AutoFilterMode = False .Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True Set rngItems = .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible) cItems = rngItems.Count ReDim dItems(1 To cItems, 1 To 2) For Each rngCell In rngItems dItems(1, i) = rngCell.Value dItems(2, i) = rngCell.Offset(0, 1).Value i = i + 1 Next rngCell Set rngItems = Nothing Set rngCell = Nothing wsData.ShowAllData 'Calculate the RM + QTY headers needed For Index = LBound(dItems, 1) To UBound(dItems, 1) With .Range("A1:C" & LastRow) .AutoFilter Field:=1, Criteria1:=dItems(1, Index) Set rngRM = .Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible) tempRM = rngRM.Count If tempRM > cRM Then cRM = tempRM End If .AutoFilter End With Next Index Set rngRM = Nothing 'Dimension the aOut array cItems = cItems + 1 aCols = (cRM * 2) + 2 ReDim aOut(1 To cItems, 1 To aCols) 'Populate the aOut array with results 'Populate headers aOut(1, 1) = "ITEM" aOut(1, 2) = "DESC" For iHeader = 3 To aCols Step 2 aOut(1, iHeader) = "RM" & n aOut(1, iHeader + 1) = "QTY" & n n = n + 1 Next iHeader 'Populate the rest of the info For iInfo = LBound(dItems, 1) To UBound(dItems, 1) aOut(x, y) = dItems(1, iInfo) y = y + 1 aOut(x, y) = dItems(2, iInfo) y = y + 1 .Range("A1:K" & LastRow).AutoFilter Field:=1, Criteria1:=dItems(1, iInfo) Set rngAreas = .Range("A2:K" & LastRow).SpecialCells(xlCellTypeVisible) For Each rngAreas In rngAreas.Areas AreaRows = rngAreas.Rows.Count For iAreas = 1 To AreaRows aOut(x, y) = rngAreas.Range("C" & iAreas).Value y = y + 1 aOut(x, y) = rngAreas.Range("K" & iAreas).Value y = y + 1 Next iAreas Next rngAreas .Range("A1:K" & LastRow).AutoFilter x = x + 1 y = 1 Next iInfo Set rngAreas = Nothing End With 'Print the array wsOutput.Range("A1").Resize(cItems, aCols).Value = aOut() Application.ScreenUpdating = True End Sub
Best Regards
-
-
-
Re: Find function Using Array for 'what:='
Hi Murphy,
Welcome to Ozgrid.
Note the changes to your code.Code
Display MoreSub ref() Dim WhatToFind As Range Dim RefNum(0 To 2) As String Dim wk As Workbook Dim ws As Worksheet Dim i As Integer RefNum(0) = "100617" RefNum(1) = "100203" RefNum(2) = "105522" Set wk = Workbooks("2004 Hourly data.xlsx") Set ws = wk.Sheets("Hourly") '.Activate For i = 0 To 2 'i = 2 Set WhatToFind = ws.Cells.Find(What:=RefNum(i), After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False) '.Activate If Not WhatToFind Is Nothing Then '...*code to do with newly found active cell* End If Next i End Sub
Best Regards
-
Re: Return multiple text rows based on search value
You are welcome.
Best Regards
Nicolas -
-
Re: Return multiple text rows based on search value
-
Re: Return multiple text rows based on search value
Put this in "Private Sub Workbook_BeforeClose(Cancel As Boolean)"
Code
Display MoreDim ws As Worksheet Dim LastRow As Long Application.EnableEvents = False For Each ws In ThisWorkbook.Worksheets(Array("MyRptSheet#1", "MyRptSheet#2", "MyRptSheet#3", "MyRptSheet#4")) With ws With .Range("C1") .Validation.Delete .Value = vbNullString End With With .Range("C2") .Validation.Delete .Value = vbNullString End With LastRow = .Range("C" & Rows.Count).End(xlUp).Row If LastRow > 4 Then .Range("B5:J" & LastRow).Clear End If End With Next ws Application.EnableEvents = True
adjusting the worksheet names to your actual report worksheet names.
Best Regards
Nicolas -
Re: Return multiple text rows based on search value
Change the previous code in "Private Sub Workbook_BeforeClose(Cancel As Boolean)" to:
Code
Display MorePrivate Sub Workbook_BeforeClose(Cancel As Boolean) Dim LastRow As Long Application.EnableEvents = False With Worksheets("Costing Report") With .Range("C1") .Validation.Delete .Value = vbNullString End With With .Range("C2") .Validation.Delete .Value = vbNullString End With LastRow = .Range("C" & Rows.Count).End(xlUp).Row If LastRow > 4 Then Range("B5:J" & LastRow).Clear End If End With Application.EnableEvents = True End Sub
-
Re: Return multiple text rows based on search value
It looks OK but:
Quote
I posted the following macro on the code page for "Costing Report":
No post it in "ThisWorkbook", see attached. -
Re: Return multiple text rows based on search value
Can you post back the macro as you modified it?
-
Re: Return multiple text rows based on search value
I modified a bit my previous post with the macro, try again
-
Re: Return multiple text rows based on search value
When you open the workbook, you get an error or something?
-
Re: Return multiple text rows based on search value
When you open the workbook, you enable macros?
You placed the macro in ThisWorkbook? (with VB editor open, on the left pane double-click on ThisWorkbook)
You changed the "Sheet2" and "D2" to your actual data? -
Re: Return multiple text rows based on search value
As a last resort to avoid this error try,
Code
Display MorePrivate Sub Workbook_BeforeClose(Cancel As Boolean) With Worksheets("Sheet2").Range("D2") .Validation.Delete .Value = vbNullString end with End Sub Private Sub Workbook_Open() With Worksheets("Sheet2").Range("D2").Validation .Delete .Add Type:=xlValidateList, Formula1:="Category,Location" End With End Sub
These macro lines should be copied in "ThisWorkbook". Change "Sheet2" to your actual sheet name (report sheet) and "D2" to your actual report cell, also change Formula1:= to actual values.
Hope that helps
Best Regards -
Re: nested transpose of multiple columns into multiple rows
I believe that a VBA solution is more "clean" & simple solution in this case, but I'm not absolute about this.
Code
Display MoreSub test() Dim aIn As Variant Dim aOut() As Variant Dim LastRow As Long, LastCol As Long, aRows As Long, i As Long, ii As Long, n As Long aIn = Range("A1").CurrentRegion.Value 'Assuming your data range starts from A1 LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastCol = Cells(1, Columns.Count).End(xlToLeft).Column aRows = (LastCol - 2) * LastRow n = 2 ReDim aOut(1 To aRows, 1 To 4) aOut(1, 1) = "Program" aOut(1, 2) = "GL" aOut(1, 3) = "Year" aOut(1, 4) = "Amount" For i = 2 To UBound(aIn, 1) For ii = 3 To LastCol aOut(n, 1) = aIn(i, 1) aOut(n, 2) = aIn(i, 2) aOut(n, 3) = aIn(1, ii) aOut(n, 4) = aIn(i, ii) n = n + 1 Next ii Next i Range("M1").Resize(aRows, 4).Value = aOut() 'Assuming you want the output to the same sheet, otherwise change to: 'Worksheets("YourSheetName").Range("YourRange").Resize(aRows,4).Value = aOut() End Sub
Best Regards
-
Re: Copying unique items to array
I don't know if its possible to "load" the dictionary keys into a "column"....
But you can create another array and load the "keys" in one column and the other data to the rest of the array "columns" likeCode
Display MoreSub test() Dim aIn As Variant Dim aOut() As Variant, FinalOut() As Variant Dim LastRow As Long, Index As Long, i As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row 'Column with data on which you want to remove duplicates - adjust aIn = Range("A1:A" & LastRow).Value 'Column with data on which you want to remove duplicates - adjust With CreateObject("Scripting.Dictionary") For Index = LBound(aIn, 1) To UBound(aIn, 1) If Not .exists(Range("A" & Index).Value) Then .Add Range("A" & Index).Value, vbNullString End If Next Index ReDim aOut(1 To .Count) aOut() = .keys 'Final array to be loaded with keys and other info ReDim FinalOut(0 To .Count, 1 To 2) For i = 0 To .Count - 1 FinalOut(i, 1) = aOut(i) FinalOut(i, 2) = i + 5 'Add data to other columns, add lines... Next i 'Dump array to range Range("C1").Resize(UBound(FinalOut, 1), 2).Value = FinalOut() End With End Sub
Hope that helps.
Best Regards