SiHodgy007
asked on
Cell Manipulation
I'm trying to manipulate a data from one layout to another. Can someone offer assistance. The data is dummy so can't be referenced. Please see the attached spread sheet.
Book1.xlsx
Book1.xlsx
ASKER
How would it look if it didn't contain question marks as not sure why it did as wrote it from scratch?
ASKER
Also the list of data could be any size
The code should still work. The function will return a zero length string for such a string and for the '?'
The code accepts settings for the start and the end rows of the input table and for the start of the output table
The code accepts settings for the start and the end rows of the input table and for the start of the output table
ASKER
I suppose I can do a cell check and row count to replace them
Not quite sure why you would need count rows. The code fits the sample you provided. You would only need to change the three values that I mentioned. If other things are different then you might need to change something else. Also if the weird invisible ? weren't there, then the code could be a bit simpler.
ASKER
The real table is Linux logs of an undertermined size. I would like to see the simpler code as the question marks aren't meant to be there
ASKER
This doesnt work in a real life example just loops and crashes excel and doesn't organise column A
Could post a more realistic example, please?
ASKER
ASKER
Not possible?\
Sorry. I lost track of his question. I'll have another look.
What your new sample tells me is that you don't need the result to start at a fixed row below the input.
From that I infer that we can terminate the process when the data runs out.
From that I infer that we can terminate the process when the data runs out.
ASKER
Yes when a complete row is empty it can terminate
Okay, here's a shot at it. This isn't too elegant, but it seems to get the job done. I took the approach of moving the data to a new sheet in it's condensed format. The Test() subroutine in the code drives this, and specifies the first row of the input data (only one row, and only as wide as the used columns), and the upper left cell of the output destination (I'd recommend this being a new empty sheet you create).
Try out the Test() procedure in the attached Excel file and you should get the results you wanted. Then see if you can adapt to your data, hopefully just changing the parms in the Test() procedure.
EE29023550.xlsm
»bp
Try out the Test() procedure in the attached Excel file and you should get the results you wanted. Then see if you can adapt to your data, hopefully just changing the parms in the Test() procedure.
Option Explicit
Sub Test()
' Execute "flatten" logic
' +> pass in the first ROW of the input data (just the used columns, only one row)
' +> pass in the first CELL of the output location
Call Flatten(Range("Input!A1:Input!D1"), Range("Flat!A1"))
End Sub
Sub Flatten(rngInput As Range, rngOutput As Range)
Dim lngWidth As Long
Dim lngRowIn As Long
Dim lngRowOut As Long
Dim lngCol As Long
Dim arrRow() As Long
' Determine how many columns wide the input data is, adjust array accordingly
lngWidth = rngInput.Columns.Count
ReDim arrRow(lngWidth)
' Initialize next row to write into for each destination column
Call SetRows(arrRow, 1)
' Process all rows of the input data until an all blank row is hit
lngRowIn = 1
Do Until False
' All blank row, end the loop
If WorksheetFunction.CountA(Range(rngInput.Cells(lngRowIn, 1), rngInput.Cells(lngRowIn, lngWidth))) = 0 Then
Exit Do
End If
' Is this a new item (first column not blank)?
If rngInput.Cells(lngRowIn, 1).Value <> "" Then
' Find the highest row used in the dest data area so far
lngRowOut = MaxRows(arrRow)
' Set all destination row indexes to start writing at this new row
Call SetRows(arrRow, lngRowOut)
' Write column one to the output
rngOutput.Cells(arrRow(1), 1).Value = rngInput.Cells(lngRowIn, 1).Value
' Bump column 1's next row number in array
arrRow(1) = arrRow(1) + 1
End If
' Now look at the data columns for this row
For lngCol = 2 To UBound(arrRow)
' If not blank, copy to destination area
If rngInput.Cells(lngRowIn, lngCol).Value <> "" Then
' Copy it to the next available row in that particular column
rngOutput.Cells(arrRow(lngCol), lngCol).Value = rngInput.Cells(lngRowIn, lngCol).Value
' Bump this columns next available row in array
arrRow(lngCol) = arrRow(lngCol) + 1
End If
Next
' Move to next row in input data
lngRowIn = lngRowIn + 1
Loop
End Sub
' Reset all entries in the row array to the same next row to write to
Sub SetRows(arrRow() As Long, lngRow As Long)
Dim i As Long
For i = LBound(arrRow) To UBound(arrRow)
arrRow(i) = lngRow
Next
End Sub
' Find the highest row any column has used so we know where to start the next item
Function MaxRows(arrRow() As Long)
Dim i As Long
Dim lngMax As Long
lngMax = -1
For i = LBound(arrRow) To UBound(arrRow)
If arrRow(i) > lngMax Then lngMax = arrRow(i)
Next
MaxRows = lngMax
End Function
EE29023550.xlsm
»bp
Here is my reworked code to take into account the updated requirements:
Option Explicit
Sub ConsolidateData()
Dim shIn As Worksheet
Dim shOut As Worksheet
Dim strCurrentLabel As String
Dim r1 As Integer
Dim r2 As Integer
Dim c As Integer
Dim strCellText As String
Dim strCol1Text As String
Dim SectionStartRow As Integer
Dim SectionEndRow As Integer
Dim CurrentRow As Integer
Dim InTableStartRow As Integer
Dim InTableEndRow As Integer
Dim OutTableStartRow As Integer
'Dim strCol1Text As String
Dim strTarget As String
Dim bTextFound As Boolean
InTableStartRow = 1
OutTableStartRow = 1
Set shIn = ActiveWorkbook.Sheets("Input")
Set shOut = ActiveWorkbook.Sheets("Output")
shOut.Range(Cells(1, 1), Cells(20, 4)).Clear
r1 = InTableStartRow
With shIn
r2 = OutTableStartRow
bTextFound = True
strCol1Text = GetCelltext(.Cells(r1, 1))
SectionStartRow = OutTableStartRow
Do While bTextFound
DoEvents
bTextFound = False
If Len(strCol1Text) > 0 Then
SectionStartRow = SectionEndRow + 1
strCurrentLabel = strCol1Text
shOut.Cells(r2, 1) = strCurrentLabel
bTextFound = True
End If
r2 = SectionStartRow
Do
DoEvents
r2 = SectionStartRow
For c = 2 To 4
strCellText = GetCelltext(.Cells(r1, c))
If Len(strCellText) > 0 Then
bTextFound = True
End If
If strCellText <> "" Then
r2 = SectionStartRow
strTarget = GetCelltext(shOut.Cells(r2, c))
Do Until strTarget = ""
r2 = r2 + 1
strTarget = GetCelltext(shOut.Cells(r2, c))
Loop
shOut.Cells(r2, c) = strCellText
If r2 > SectionEndRow Then
SectionEndRow = r2
End If
End If
Next c
r1 = r1 + 1
strCol1Text = GetCelltext(.Cells(r1, 1))
Loop While (strCol1Text = strCurrentLabel) And bTextFound
Loop
End With
End Sub
Function GetCelltext(rng As Range) As String
If Len(rng.Value) = 0 Then
Exit Function
End If
If Asc(rng.Value) = 63 Then
Exit Function
End If
GetCelltext = rng.Value
End Function
ASKER
Does that still have code in it to deal with question marks?
ASKER
It doesn't bring in the column A line headers just the cartoon characters. Here's the spread sheet I tested it against
Book1.xlsx
Book1.xlsx
Okay, adjusted my code to handle the "?" which I see is actually a Chr(63) and treat those as empty as well. Here is the updated code, and the results I got here.
»bp
Option Explicit
Sub Test()
' Execute "flatten" logic
' +> pass in the first ROW of the input data (just the used columns, only one row)
' +> pass in the first CELL of the output location
Call Flatten(Range("Sheet1!A1:Sheet1!D1"), Range("Sheet2!A1"))
End Sub
Sub Flatten(rngInput As Range, rngOutput As Range)
Dim lngWidth As Long
Dim lngRowIn As Long
Dim lngRowOut As Long
Dim lngCol As Long
Dim arrRow() As Long
' Determine how many columns wide the input data is, adjust array accordingly
lngWidth = rngInput.Columns.Count
ReDim arrRow(lngWidth)
' Initialize next row to write into for each destination column
Call SetRows(arrRow, 1)
' Process all rows of the input data until an all blank row is hit
lngRowIn = 1
Do Until False
' All blank row, end the loop
If WorksheetFunction.CountA(Range(rngInput.Cells(lngRowIn, 1), rngInput.Cells(lngRowIn, lngWidth))) = 0 Then
Exit Do
End If
' Is this a new item (first column not blank)?
If NotEmpty(rngInput.Cells(lngRowIn, 1)) Then
' Find the highest row used in the dest data area so far
lngRowOut = MaxRows(arrRow)
' Set all destination row indexes to start writing at this new row
Call SetRows(arrRow, lngRowOut)
' Write column one to the output
rngOutput.Cells(arrRow(1), 1).Value = rngInput.Cells(lngRowIn, 1).Value
' Bump column 1's next row number in array
arrRow(1) = arrRow(1) + 1
End If
' Now look at the data columns for this row
For lngCol = 2 To UBound(arrRow)
' If not blank, copy to destination area
If NotEmpty(rngInput.Cells(lngRowIn, lngCol)) Then
' Copy it to the next available row in that particular column
rngOutput.Cells(arrRow(lngCol), lngCol).Value = rngInput.Cells(lngRowIn, lngCol).Value
' Bump this columns next available row in array
arrRow(lngCol) = arrRow(lngCol) + 1
End If
Next
' Move to next row in input data
lngRowIn = lngRowIn + 1
Loop
End Sub
' Reset all entries in the row array to the same next row to write to
Sub SetRows(arrRow() As Long, lngRow As Long)
Dim i As Long
For i = LBound(arrRow) To UBound(arrRow)
arrRow(i) = lngRow
Next
End Sub
' Find the highest row any column has used so we know where to start the next item
Function MaxRows(arrRow() As Long)
Dim i As Long
Dim lngMax As Long
lngMax = -1
For i = LBound(arrRow) To UBound(arrRow)
If arrRow(i) > lngMax Then lngMax = arrRow(i)
Next
MaxRows = lngMax
End Function
' Check if cell is empty, or starts with Chr(63) to determine if it has data
Function NotEmpty(rngCell As Range) As Boolean
NotEmpty = True
If Len(rngCell.Value) = 0 Then
NotEmpty = False
Exit Function
End If
If Asc(rngCell.Value) = 63 Then
NotEmpty = False
Exit Function
End If
End Function
»bp
ASKER
Hi Bill,
That works well on the code I sent over but doesn't work on my data. My imported value a1 doesn't work but type over it and it does work. The formatting of the cells is identical. Any ideas?
That works well on the code I sent over but doesn't work on my data. My imported value a1 doesn't work but type over it and it does work. The formatting of the cells is identical. Any ideas?
We really need to see a sample of the real data to debug this effectively. Please prepare and upload a sample...
»bp
»bp
ASKER
This has the issue
Book1.xlsm
Book1.xlsm
My latest macro was designed to stop on the first blank line and would have worked with your first two samples. The sample that you used in test (Happy) has a blank line in the middle of the data. A procedure to run down to the last filled line in the sheet would fail on your first sample if that criterion is used.
Ideally you need to say what you need to happen and not just rely on samples with their own idiosyncrasies.
Ideally you need to say what you need to happen and not just rely on samples with their own idiosyncrasies.
ASKER
Thats not the issue, if you run the macro it doesn't bring in the column a details
ASKER
The macro is in the spreadsheet i sent
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Perfect, what was the final issue?
The funny characters that seem to be sprinkled throughout the data values (CHR(63)) needed to be handled on every cell, and sometimes they preceded actual values.
»bp
»bp
ASKER
Sorry to ask so many questions but how could you see those characters?
One way is just to select the original data cells in Excel, copy that (ctrl-c) and then open a text editor and paste (ctrl-v) there. That showed the odd characters as question marks in my editor (SlickEdit Pro) and also allowed me to see the data in hex mode. You could probably save the Excel sheet as a CSV and browse it with a Hex Editor too I suspect.
In addition I used Debug.Print while debugging the macro to view the various cell values as the code ran, and used the ASC() function to display the ascii values of cell data as it processed.
»bp
In addition I used Debug.Print while debugging the macro to view the various cell values as the code ran, and used the ASC() function to display the ascii values of cell data as it processed.
»bp
ASKER
Ok this script works great, but if the sheet has a space in which mine does it doesn't work. Is there a work around for this? i.e. Sheet2 works but sheet 2 won't work
Yes, single quote the sheet name, as in:
»bp
Call Flatten(Range("'Sheet 1'!A1:'Sheet 1'!D1"), Range("'Sheet 2'!A1"))
»bp
ASKER
Super, One last thing if possible. Can the output write the values starting at column 4,
So the Heading in A1 then the value starting at A4?
So the Heading in A1 then the value starting at A4?
Super, One last thing if possible. Can the output write the values starting at column 4,
So the Heading in A1 then the value starting at A4?
That is not clear, you mention "column 4" but then you refer to "A4" which would be row 4? Which is it, do you want it to start in D1?
If so make this change:
rngOutput.Cells(arrRow(lngCol), lngCol + 2).Value = strValue
»bp
ASKER
Sorry stand corrected yes the output from D1
Okay, I added the single line of code to change above...
»bp
»bp
ASKER
Thanks for all your help, much appreciated.
The function GetCellText is intended to cope with that.
Open in new window