I have dynamic rows in Column"A" on Sheet1 which are populated on Listbox selection form.
111
222
333
444
....
Now on my Sheet2 I have these data transposed on Row B2 as:
111 | 222 | 333 | 444 | ...
I want to for any selection of items in listbox, code hide correspondent Column. If I select 111 and 333 in the Listbox, it hides entire Column "A" and "C".
Hope it make sense. OK button is supposed to run the code.
Private Sub cmdOK_Click()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim i As Integer, hdn2 As String
Dim hdn3 As Variant, col As Long, header As Range
Set sh2 = ActiveWorkbook.Sheets("Sheet2")
Set header = sh2.Range("2:2")
For i = 0 To Me.lstMultiChoice.ListCount - 1
col = Application.WorksheetFunction.Match(lstMultiChoice.List(i, 0), header, 0)
If Me.lstMultiChoice.Selected(i) = True Then
sh2.Columns(col).Hidden = False
hdn2 = hdn2 & lstMultiChoice.List(i, 0) & ","
Else
sh2.Columns(col).Hidden = True
End If
Next
Set sh1 = ActiveWorkbook.Sheets("List Data")
hdn3 = Split(Left(hnd2, Len(hdn2) - 1), ",")
sh2.Range(sh2.Cells(4, 4), sh2.Cells(4 + UBound(hdn3), 4)).Value = Application.Transpose(hdn3)
End Sub
I made a new answer for you because editing made a monster out of the other one.
Code now includes looking up where the column really is.
You need to add a line to clear the previous entries starting in D4, because if the previous list was longer, some entries will stay there. You also need error trapping in case the col is not found.
Private Sub ListBox1_Change()
Dim sh2 As Worksheet
Dim i As Integer, hdn2 as string
Dim hdn3 as Variant, col as long, header as Range
Set sh2 = ActiveWorkbook.Sheets("Sheet2")
Set header = sh2.Range("2:2")
For i = 0 To Me.ListBox1.ListCount - 1
col = Application.WorksheetFunction.Match(ListBox1.List(i, 0), header, 0)
If Me.ListBox1.Selected(i) = True Then
sh2.Columns(col).Hidden = True
hdn2 = hdn2 & ListBox1.List(i, 0) & ","
Else
sh2.Columns(col).Hidden = False
End If
Next
hdn3 = Split(Left(hnd2, Len(hdn2) - 1), ",")
Sheet1.Range(Sheet1.Cells(4, 4), Sheet1.Cells(4 + UBound(hdn3), 4)).Value = Application.Transpose(hdn3)
End Sub
If I understand you correctly this is what you need:
Private Sub ListBox1_Change()
Dim sh1 As Worksheet
Dim i As Integer, hdn as string
Set sh1 = ActiveWorkbook.Sheets("Sheet2")
hdn = "Hidden columns: "
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
sh1.Columns(i + 1).Hidden = True
hdn = hdn & ListBox1.List(i, 0) & ", "
Else
sh1.Columns(i + 1).Hidden = False
End If
Next
Sheet1.Cells(4, 4).Value = Left(hdn, Len(hdn) - 2)
End Sub
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
I have a list with 3 variables in the sheet "Combined" in columns A; B; C.
The workbook contains 98 sheets, with those 3 variables still in A; B; C columns but in different combinations and with a fourth column which never repeats itself, as the sheets go on, which i need to bring in the "Combined" sheet, always adding another column for the next sheet I vlookup. : A B C + D(from the next sheet) + E(from the next sheet) and so on.
I have a UDF that Vlookups on 3 based on 3 criterias and a macro that cycles through the sheets and bring the values where i want them. The problem is, it's pretty slow, left it from yesterday and its on sheet 60. Any suggestions on improving it would greatly help, Thank you in advance!
Function ThreeVlookup(Table_Range As Range, Return_Col As Long, Col1_Fnd, Col2_Fnd, Col3_Fnd)
Dim rCheck As Range, bFound As Boolean, lLoop As Long
On Error Resume Next
Set rCheck = Table_Range.Columns(1).Cells(1, 1)
With WorksheetFunction
For lLoop = 1 To .CountIf(Table_Range.Columns(1), Col1_Fnd)
Set rCheck = Table_Range.Columns(1).Find(Col1_Fnd, rCheck, xlValues, xlWhole, xlNext, xlRows, False)
If UCase(rCheck(1, 2)) = UCase(Col2_Fnd) And UCase(rCheck(1, 3)) = UCase(Col3_Fnd) Then
bFound = True
Exit For
End If
Next lLoop
End With
If bFound = True Then
ThreeVlookup = rCheck(1, Return_Col)
Else
ThreeVlookup = ""
End If
End Function
Sub test()
Dim lookupVal1 As Range, lookupVal2 As Range, lookupVal3 As Range, myString As Variant, n&, u As Long
n = Sheets("Combined").[A:A].Cells.Find("*", , , , xlByRows, xlPrevious).Row
u = 4
For j = 2 To Worksheets.Count
For i = 1 To n
Set lookupVal1 = Sheets("Combined").Cells(i, 1)
Set lookupVal2 = Sheets("Combined").Cells(i, 2)
Set lookupVal3 = Sheets("Combined").Cells(i, 3)
myString = ThreeVlookup(Sheets(j).Range("A:D"), 4, lookupVal1, lookupVal2, lookupVal3)
Sheets("Combined").Cells(i, u) = myString
Next i
u = u + 1
Next j
End Sub
Use Arrays to speed it up, my friend! Load all your sheets (or just the current sheet in the loop) into an array in VBA's memory and do the .CountIf and .Find on arrayVar(row) instead of Table_Range.Columns(1).
You will be really surprised how much quicker it goes. Do it!
Here's a tutorial I like on arrays...
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Here's a guy who speed-tested an application like yours...
https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
The basics is like this:
Sub Play_With_Arrays()
Dim varArray() As Variant
Dim lngArray() As Long
ReDim varArray(1 To 1000)
ReDim lngArray(1 To 1000)
For A = 1 To 1000
lngArray(A) = A / 2
varArray(A) = A / 2 & " examples"
Next
searchterm = 345
For B = 1 To 1000
If lngArray(B) = searchterm Then
FoundRow = B
End If
Next
searchterm2 = "5 ex"
FoundStrRowCount = 0
For C = 1 To 1000
If InStr(1, varArray(C), searchterm2, vbBinaryCompare) Then
FoundStrRowCount = FoundStrRowCount + 1
End If
Next
MsgBox (FoundRow & " in long array and " & FoundStrRowCount & " in var array")
End Sub
Something like this should be much faster:
Public Function ThreeVLookup(ByVal arg_Col1LookupVal As Variant, _
ByVal arg_Col2LookupVal As Variant, _
ByVal arg_Col3LookupVal As Variant, _
ByVal arg_LookupTable As Range, _
ByVal arg_ReturnColumn As Long) _
As Variant
Dim rConstants As Range, rFormulas As Range
Dim rAdjustedTable As Range
Dim aTable As Variant
Dim i As Long
On Error Resume Next
Set rConstants = arg_LookupTable.SpecialCells(xlCellTypeConstants)
Set rFormulas = arg_LookupTable.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case (Not rConstants Is Nothing) + 2 * (Not rFormulas Is Nothing)
Case 0: ThreeVLookup = vbNullString
Exit Function
Case -1: Set rAdjustedTable = rConstants
Case -2: Set rAdjustedTable = rFormulas
Case -3: Set rAdjustedTable = Union(rConstants, rFormulas)
End Select
If WorksheetFunction.CountIfs(rAdjustedTable.Resize(, 1), arg_Col1LookupVal, rAdjustedTable.Resize(, 1).Offset(, 1), arg_Col2LookupVal, rAdjustedTable.Resize(, 1).Offset(, 2), arg_Col3LookupVal) = 0 Then
ThreeVLookup = vbNullString
Exit Function
End If
aTable = rAdjustedTable.Value
For i = LBound(aTable, 1) To UBound(aTable, 1)
If aTable(i, 1) = arg_Col1LookupVal And aTable(i, 2) = arg_Col2LookupVal And aTable(i, 3) = arg_Col3LookupVal Then
ThreeVLookup = aTable(i, arg_ReturnColumn)
Exit Function
End If
Next i
End Function
Sub tgr()
Dim wb As Workbook
Dim wsCombined As Worksheet
Dim ws As Worksheet
Dim aResults() As Variant
Dim aCombined As Variant
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsCombined = wb.Sheets("Combined")
aCombined = wsCombined.Range("A1").CurrentRegion.Value
ReDim aResults(1 To UBound(aCombined, 1) - LBound(aCombined, 1) + 1, 1 To wb.Sheets.Count - 1)
For i = LBound(aCombined, 1) To UBound(aCombined, 1)
j = 0
For Each ws In wb.Sheets
If ws.Name <> wsCombined.Name Then
j = j + 1
aResults(i, j) = ThreeVLookup(aCombined(i, 1), aCombined(i, 2), aCombined(i, 3), ws.Range("A:D"), 4)
End If
Next ws
Next i
wsCombined.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
I've included the base code that currently runs to essentially pull out info for a specific product category based on a larger master listing (approx. 4000 lines by 36 columns). Previously this was not an issue, as the only codes listed and pulled out to individual sheets, were all is use; over time though, some of the older assigned product numbers are being discontinued and no longer in use. All I'm trying to do is modify the existing structure so that it first does a sweep through the master listing to verify whether or not any lines match the c.Value and d.Value - if there are no lines that meet the matching c.Value and d.Value criteria then it should just perform the action in the If statement inside the loop (ie. delete the old sheet, make a new one, and populate "G2" with a generic "item code not located" value); if any lines are found that meet the c and d.value criteria then it goes through the normal process.
Option Explicit
Sub Item()
CreateDeptReport "Item"
End Sub
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
On Error GoTo Err_Execute
Application.ScreenUpdating = False
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
LCopyToRow = 11
Do
If c.Value = 2516 And d.Value = "37A" And Not e.Value = "T1" And Not e.Value = "T3" Then
If shtRpt Is Nothing Then
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Item").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = "Item"
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until IsEmpty(c.Offset(0, -1))
ThisWorkbook.Worksheets("Item").Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
It seems to me that you always want a new Worksheet for the Item.
So create the new worksheet first, then run the routine to find and fill the new worksheet with the records from the Master worksheet and use a variable (Dim blItmFound As Boolean) to flag when any record is found and at the end if there where no records found then enter in the new worksheet at G2 the generic string you want (see Rem Validate Records).
Please note that I changed "Item" for the value of the Variable Item and also changed this line:
Loop Until IsEmpty(c.Offset(0, -1))
for this:
Loop Until c.Value = Empty
for more details see IsEmpty Function
This is your code adjusted:
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
Dim blItmFound As Boolean
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Application.ScreenUpdating = False
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
Rem Delete Item Worksheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Item).Delete
Application.DisplayAlerts = True
On Error GoTo Err_Execute
Rem Add New Item Worksheet
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = Item
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
Rem Get Records from Master
LCopyToRow = 11
blItmFound = False
Do
If c.Value = 2516 _
And d.Value = "37A" _
And Not e.Value = "T1" _
And Not e.Value = "T3" Then
blItmFound = True
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until c.Value = Empty
Rem Validate Records
Select Case blItmFound
Case True
ThisWorkbook.Worksheets(Item).Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Case False
ThisWorkbook.Worksheets(Item).Range("G2").Value = "Item: [" & Item & "] code not located"
End Select
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Based on what I've read, it sounds like you should just search for the values in their respective columns beforehand. This is also assuming that if one of those conditions is false, you'll enter your new code. So you could do something like:
Set cRange = shtMaster.Columns("AI:AI")
Set dRange = shtMaster.Columns("H:H")
If cRange.Find(2516) Is Nothing Or dRange.Find("37A") Is Nothing Then
'do code when either one of these conditions is false
Else
'both values are found in their respective columns
'do existing code
EDIT:
Set rng = Range("AI:AI")
Set origCell = rng.Find(2516)
Set currCell = origCell
Do
Set currCell = rng.FindNext(currCell)
If shtMaster.Range("H" & currCell.Row).Value = "37A" Then
boolMatchingPair = True
Exit Do
End If
Loop While currCell.Row <> origCell.Row
If boolMatchingPair = True
'found match
Else
'no match
I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B
Row1 ABC ABD ABE ABF | CODE1
Row2 BCA DBA EBA FBA | CODE2
Row3 TEA BEF | CODE3
The result would be:
A B
ABC CODE1
ABD CODE1
ABE CODE1
ABF CODE1
BCA CODE2
DBA CODE2
EBA CODE2
FBA CODE2
TEA CODE3
BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2)
' The result will be ...
"EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.
I like iterating over cells for problems like this post.
' code resides on input sheet
Sub ParseData()
Dim wksOut As Worksheet
Dim iRowOut As Integer
Dim iRow As Integer
Dim asData() As String
Dim i As Integer
Dim s As String
Set wksOut = Worksheets("Sheet2")
iRowOut = 1
For iRow = 1 To UsedRange.Rows.Count
asData = Split(Trim(Cells(iRow, 1)), " ")
For i = 0 To UBound(asData)
s = Trim(asData(i))
If Len(s) > 0 Then
wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
wksOut.Cells(iRowOut, 2) = s
iRowOut = iRowOut + 1
End If
Next i
Next iRow
MsgBox "done"
End Sub
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
Public Sub FixIt()
Dim fromSheet, toSheet As Excel.Worksheet
Dim fromRow, toRow, k As Integer
Dim code As String
Set fromSheet = Me.Worksheets(1)
Set toSheet = Me.Worksheets(2)
' Ignore first row
fromRow = 2
toRow = 1
Dim outsideArr() As String
Dim insideArr() As String
Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""
' Split on the pipe
outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")
' Split left of pipe, trimmed, on space
insideArr = Split(Trim(outsideArr(0)), " ")
' Save the code
code = Trim(outsideArr(UBound(outsideArr)))
' Skip first element of inside array
For k = 1 To UBound(insideArr)
toSheet.Cells(toRow, 1).Value = insideArr(k)
toSheet.Cells(toRow, 2).Value = code
toRow = toRow + 1
Next k
fromRow = fromRow + 1
Loop
End Sub
Let me try as well using Dictionary :)
Sub Test()
Dim r As Range, c As Range
Dim ws As Worksheet
Dim k, lrow As Long, i As Long
Set ws = Sheet1 '~~> change to suit, everything else as is
Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In r
If Not .Exists(c.Value) Then
.Add c.Value, Split(Trim(c.Offset(0, -1).Value))
End If
Next
ws.Range("A:B").ClearContents
For Each k In .Keys
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lrow = 1 Then i = 0 Else i = 1
ws.Range("A" & lrow).Offset(i, 0) _
.Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
Next
End With
End Sub
Above code loads all items in Dictionary and then return it in the same Range. HTH.
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "CodeData"
Option Explicit
Private pData As String
Private pCode As String
Property Get Data() As String
Data = pData
End Property
Property Let Data(Value As String)
pData = Value
End Property
Property Get Code() As String
Code = pCode
End Property
Property Let Code(Value As String)
pCode = Value
End Property
Then put the following code into a Regular module:
Option Explicit
Sub ParseCodesAndData()
Dim cCodeData As CodeData
Dim colCodeData As Collection
Dim vSrc As Variant, vRes() As Variant
Dim V As Variant
Dim rRes As Range
Dim I As Long, J As Long
'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")
'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))
'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), " ")
For J = 0 To UBound(V)
Set cCodeData = New CodeData
cCodeData.Code = Trim(vSrc(I, 2))
cCodeData.Data = Trim(V(J))
colCodeData.Add cCodeData
Next J
Next I
'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
Set cCodeData = colCodeData(I)
vRes(I, 1) = cCodeData.Data
vRes(I, 2) = cCodeData.Code
Next I
'Write array to worksheet
Application.ScreenUpdating = False
rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes
Application.ScreenUpdating = True
End Sub
Here is the solution I devised with help from above. Thanks for the responses!
Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("B1:C" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
I am trying to copy paste a row of values from one sheet to another but keep coming up with the run-time error 1004: Application-defined or object-defined error.
the error is in the first line of the two below and I do not know where I am going wrong.
Set copyRange = Worksheets("Sheet2").range(A & i + 1 & CA & i + 1)
copyRange.Copy Destination:=Cells(countD, 2)
the code needs to copy a line at a time and paste it into the default sheet.
Edit
full code
Dim List1 As range
Dim List2 As range
Dim lastRow As Integer
Dim countD As Integer
Dim found As Boolean
Dim copyRange As range
Set List1 = ThisWorkbook.Sheets("Sheet1").range("H2:H600")
Set List2 = ThisWorkbook.Sheets("Sheet2").range("I2:I600")
countD = 2
lastRow = Application.CountA(ThisWorkbook.Sheets("Sheet2").range("C:C"))
For i = lastRow To 2 Step -1
found = False
value1 = List1.Item(i, 1)
For Each value2 In List2
If value1 = value2 Then
found = True
Exit For
End If
Next
If found = False Then
Set copyRange = Sheets("Sheet1").range("A" & i + 1 & "CA" & i + 1)
copyRange.Copy Destination:=Cells(countD, 2)
Sheets("Discrepancies").Cells(countD, 1) = "name not found"
ThisWorkbook.Sheets("Sheet1").Cells(i + 1, 1).EntireRow.Delete
Cells(countD, 8).Interior.ColorIndex = 3
countD = countD + 1
End If
Next
Exactly as Vasim's comment mentions - with the addition of a colon : in front of the CA
Sub copyRangeOver()
Dim i As Integer
i = 6
Dim copyRange As Range
Set copyRange = ThisWorkbook.Worksheets("Sheet2").Range("A" & i + 1 & ":CA" & i + 1)
Dim countD As Integer
countD = 10
copyRange.Copy Destination:=Cells(countD, 2)
End Sub