I received many Excel files from a client.
Their system extracted the data into a spreadsheet, but one column is having issues. If the text was too long, it would put the remaining text into the cell below it.
This causes all the other fields in that row to be blank, except for the overflow.
How can I merge cells at issue into one for all files I received?
I uploaded a screen shot of the file as an example. Notice on row 8 that H8 is the only cell. That needs to be merged with H7. Not every row is at issue though.
asuming A is the main (and empty for doubles)
asuming H holds the text
then in L1 and copy down
=H1&IF(LEN(A2),H2,"")
simplest way (then copy values from L to H and delete empty lines (simply with filter)
when having unknown number of lines (after splitting) you better use vba (or simply repeat the whole procedure till there no empty lines anymore...
doing it in VBA:
Sub testing()
Dim i As Long
While Len(Cells(i + 1, 8))
i = i + 1
While Len(Cells(i + 1, 1)) = 0 And Len(Cells(i + 1, 8))
Cells(i, 8) = Cells(i, 8) & Cells(i + 1, 8)
Rows(i + 1).Delete
Wend
Wend
End Sub
most programs skip spaces so you may want to use:
=H1&IF(LEN(A2)," "&H2,"")
or for vba change Cells(i, 8) = Cells(i, 8) & Cells(i + 1, 8) to Cells(i, 8) = Cells(i, 8) & " " & Cells(i + 1, 8)
This will concatenate the texts in H and delete the row that is not useful :
Sub test_bm11()
Dim wS As Worksheet, _
LastRow As Long, _
i As Long
Set wS = ActiveSheet
With wS
LastRow = .Range("H" & .Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
If .Cells(i, "A") <> vbNullString Then
Else
.Cells(i, "H").Offset(-1, 0) = .Cells(i, "H").Offset(-1, 0) & .Cells(i, "H")
.Cells(i, "H").EntireRow.Delete
End If
Next i
End With
End Sub
Related
Got any Way to Arrange The data like the picture attached?
*the requirement is when the Column A Cell is empty then Column B Value will Move to previous not Empty Column A Row at Column B Cell.
Example Photo
Try this code
Sub Macro1()
Dim i As Long
i = 1
Do Until Cells(i, 2) = ""
If Cells(i, 1) = "" Then
On Error Resume Next
Cells(i - 1, 2) = Cells(i - 1, 2) & "," & Cells(i, 2)
Cells(i, 2).EntireRow.Delete
i = i - 1
End If
i = i + 1
Loop
End Sub
The macro below opens a series of workbooks from a list, then copies some data from them. It works fine for the first workbook, then crashes on the second. I've tried changing the order, and it's always the second workbook that causes it to crash.
Sub ImportData()
Dim lastRow As Long
Dim lastSumRow As Long
Dim j As Long
Dim k As Long
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
For k = 2 To lastRow
k = 2
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
If ActiveSheet.Cells(k, 2).Value <> "Imported" Then
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
ActiveWorkbook.Sheets("Summary").Activate
For j = 3 To 100
If j Mod 3 = 0 Then
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ActiveWorkbook.Sheets("Summary").Cells(j, 1).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 4).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 5).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 6).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 7).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 8).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 5).Value
End If
Next j
ActiveWorkbook.Close
End If
ThisWorkbook.Sheets("Setup").Cells(k, 2).Value = "Imported"
Next k
End Sub
I'm guessing your error is here:
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
'Ooops ^^^^^
The .Activate and .Select calls are convoluted enough that I'm not really going to expend the effort figuring out what should be the active worksheet at that particular point in your code on the second run through the loop. Whatever it is, it's different than it was when you started and an unqualified call to Cells implicitly refers to whatever worksheet is the ActiveSheet at the time. This builds a bad file name (or fails completely) and then the wheels come off.
The best thing to do is not use the Active* objects at all. Get references to the objects that you're using, and well, use them. That way there is no chance that you'll get wires crossed. While you're at it, you can give them names that make it obvious what you're working with at a glance.
Couple other things before we get to the code that doesn't use Activate and Select.
lastSumRow is never used and lastUsedRow is never declared. I'm assuming they were supposed to be the same thing. You should put Option Explicit at the top of your modules to avoid this type of error (and worse ones).
These 2 lines of code make very little sense together:
For j = 3 To 100
If j Mod 3 = 0 Then
If you only want to copy every 3rd row, skip all the division and just increment your loop counter with a Step of 3:
For j = 3 To 99 Step 3
Note that you can stop at 99, because 100 Mod 3 is never going to be 0.
Your With block here isn't using the captured reference...
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
...but you continually use this pattern that would be useful in a With block:
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ...
Hard-coding Cells(1048576, 1) will fail on older versions of Excel. You should use Rows.Count instead.
As mentioned in the comments, k = 2 creates an infinite loop.
You don't need to repeatedly find the last row of the sheet you're copying to with this code:
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
Each time you go through your "j" loop, the last row increases by one. Just add 1 to lastUsedRow instead of doing all the row counting gymnastics.
If you're working with Worksheets, use the Worksheets collection instead of the Sheets collection:
ThisWorkbook.Sheets("Summary") '<--I could return a Chart!
Put all of that together, and you come up with something like the code below. Note that I have no clue what the ActiveSheet is supposed to be when you start this macro, so I just named the variable it's stored in active. It's quite possible that it's one of the other worksheets it grabs a reference too (I have no clue) - if so, you should consolidate them into one reference:
Public Sub ImportData()
Dim lastRow As Long
Dim lastUsedRow As Long
Dim dataRow As Long
Dim fileNameRow As Long
Dim active As Worksheet
Set active = ActiveSheet
With active
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim setupSheet As Worksheet
Set setupSheet = ThisWorkbook.Worksheets("Setup")
With ThisWorkbook.Worksheets("Summary")
lastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For fileNameRow = 2 To lastRow
If active.Cells(fileNameRow, 2).Value <> "Imported" Then
Dim source As Workbook
Set source = Workbooks.Open(ThisWorkbook.Path & "\Analysis\" & _
active.Cells(fileNameRow, 1), False)
Dim dataSheet As Worksheet
Set dataSheet = source.Worksheets("Summary")
For dataRow = 3 To 99 Step 3
.Cells(lastUsedRow, 1).Value = dataSheet.Cells(dataRow, 1).Value
.Cells(lastUsedRow, 2).Value = dataSheet.Cells(dataRow + 1, 2).Value
.Cells(lastUsedRow, 3).Value = dataSheet.Cells(dataRow + 1, 3).Value
.Cells(lastUsedRow, 4).Value = dataSheet.Cells(dataRow + 1, 4).Value
.Cells(lastUsedRow, 5).Value = dataSheet.Cells(dataRow + 2, 2).Value
.Cells(lastUsedRow, 6).Value = dataSheet.Cells(dataRow + 2, 3).Value
.Cells(lastUsedRow, 7).Value = dataSheet.Cells(dataRow + 2, 4).Value
.Cells(lastUsedRow, 8).Value = dataSheet.Cells(dataRow + 1, 5).Value
lastUsedRow = lastUsedRow + 1
Next
source.Close
End If
setupSheet.Cells(fileNameRow, 2).Value = "Imported"
Next
End With
End Sub
I have an Excel sheet with cells in some columns merged:
I need to normalize it, such that the cells in the first column are unmerged (those should be considered the true "rows"), but such that unmerged groups of cells (in these "rows") are put into a single cell with newlines to retain the list-like content:
Note that in some columns besides the first, there may also be some merged cells, but in any case the first column should determine what a "row" in the output sheet should look like.
Does such a VBA script exist to do this?
UPDATE: Here's a little pseudo-code for what I was thinking:
foreach row:
determine height of merged cell in column A
unmerge cell in column A (content is in top cell of range?)
for each column after A:
if cell is merged, unmerge (content is in top cell of range?)
else concatenate cell contents with newline separator in top cell of row range
cleanup excess rows from the unmerging
Unfortunately I think there's a bit of complexity in some of these steps.
UPDATE#2: Based on the accepted answer, I created some new code to accomplish my goals:
Sub dlo()
Dim LastRow&, r&, c&, rowheight&, n&, Content$, NewText$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To LastRow
If Cells(r, 1).MergeCells Then
rowheight = Cells(r, 1).MergeArea.Cells.Count
For c = 1 To LastCol
NewText = vbNullString
For rr = r To (r + rowheight - 1)
Content = Cells(rr, c)
Cells(rr, c) = vbNullString
NewText = NewText & vbCrLf & Content
Next
Cells(r, c).UnMerge
Cells(r, c) = NewText
Next
'Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
'LastRow = LastRow - rowheight + 1
End If
DoEvents
Next
Application.DisplayAlerts = True
End Sub
The only thing I didn't finish was the deletion of resulting blank rows (I ended up just commenting those out since I knew a could just sort the table to eliminate the blanks).
If anyone has better ideas for how to describe this, please let me know so I can edit the title... I have a feeling this is not a rare need, so I'd like to help other find this.
Is this what you asking for?
Sub dlo()
Dim LastRow&, i&, j&, k&, n&, Content$, Text$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Do
i = i + 1
Text = vbNullString
If Cells(i, 1).MergeCells Then
k = Cells(i, 1).MergeArea.Cells.Count
n = Cells(i, 1).RowHeight
For j = 1 To k
Content = Cells(j + i - 1, 2)
Cells(j + i - 1, 2) = vbNullString
Text = Text & vbCrLf & Content
Next
Cells(i, 1).UnMerge
Cells(i, 2) = Mid(Text, 3)
Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
Rows(i).RowHeight = n * k
NewLastRow = LastRow - k + 1
End If
DoEvents
Loop Until i = NewLastRow
Application.DisplayAlerts = True
End Sub
The above code works fine to my dummy data.
I'm trying to run a For Next Loop until the last row of a specific column (but not the last row of the sheet). So the first part of my list has data in column F and the second part doesn't. I only want the macro to apply to that first part. For some reason the loop only runs through the first part with certain commands but doesn't with the ones I am trying to do now. (I know it would be easy just to seperate the two parts manually and then run it but it drives me nuts not knowing what it is I did wrong :)).
This is the code:
Dim i As Integer
Dim g As Double
g = 0.083333333
Dim lastrow As Long
lastrow = Sheets("zm").Range("f" & Rows.Count).End(xlUp).Row
Sheets("zm").Activate
For i = 2 To lastrow
If Sheets("zm").Cells(i, 1) = Sheets("zm").Cells(i + 1, 1) And Sheets("zm").Cells(i, 5) = Sheets("zm").Cells(i + 1, 5) And Sheets("zm").Cells(i + 1, 6) - Sheets("zm").Cells(i, 7) < g Then
Sheets("zm").Cells(i + 1, 7).Copy
Sheets("zm").Cells(i, 7).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("zm").Rows(i + 1).Delete
End If
Next i
Thanks for your help!
avoid Select/Selection and/or Activate/ActiveXXX
try this:
Option Explicit
Sub main()
Dim i As Long, lastrow As Long
Dim g As Double
g = 0.083333333
With Worksheets("zm")
lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = lastrow To 2 Step -1
If .Cells(i, 1) = .Cells(i + 1, 1) And .Cells(i, 5) = .Cells(i + 1, 5) And .Cells(i + 1, 6) - .Cells(i, 7) < g Then
.Cells(i + 1, 7).Copy Destination:=.Cells(i, 7)
.Rows(i + 1).Delete
End If
Next i
End With
End Sub
This is my code:
Dim RowLast As Long
Dim sunmLast As Long
Dim tempLast As Long
Dim filterCriteria As String
Dim perporig As Workbook
Dim x As String
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "E").End(xlUp).Row
Range("D5:G" & tempLast).ClearContents
Range("G5:G" & tempLast).Interior.ColorIndex = 0
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "A").End(xlUp).Row
Range("A5:A" & tempLast).ClearContents
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "B").End(xlUp).Row
'Perpetual
Set perporig = Workbooks.Open("\\Etnfps02\vol1\DATA\Inventory\Daily tracking\perpetual.xlsx", UpdateLinks:=False, ReadOnly:=True)
RowLast = perporig.Sheets("perpetual").Cells(Rows.Count, "A").End(xlUp).Row
perporig.Sheets("perpetual").Cells(3, 1) = "Part Number"
For i = 5 To tempLast
Cells(i, 1) = i - 4
perporig.Sheets("perpetual").AutoFilterMode = False
filterCriteria = ThisWorkbook.Sheets("combine BOMs").Range("B" & i).Value
perporig.Sheets("perpetual").Range("A3:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
Counter = perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
If Counter = 3 Then
Cells(i, 5).Value = "Not on perpetual"
Else
ThisWorkbook.Sheets("combine BOMs").Cells(i, 5).Value = WorksheetFunction.Sum(perporig.Sheets("perpetual").Range("H4:H" & RowLast).SpecialCells(xlCellTypeVisible))
x = perporig.Sheets("perpetual").Cells(Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
ThisWorkbook.Sheets("combine BOMs").Cells(i, 4).Value = x
End If
perporig.Sheets("perpetual").AutoFilterMode = False
Next
perporig.Close savechanges:=False
This is the file from which I am clicking my button (or ThisWorkbook)
This is the perpetual file when it is running on the last row of data:
Notice the difference in D9280: it shows stocking type as "P" in the perpetual file, but "B" in my final result, which comes up in cell D12 in ThisWorkbook. To debug, I created a Msgbox prompt for everytime it gets that value for all rows. For every other row, it gives the correct value ("P"), but for this one, msgbox shows "B". The title of the msgbox is the row number, which shows it is taking the correct row whilr getting the value, just that I don't know why it is taking wrong value. I have tried for different data sources, it seems to be coming up with "B" in wrong places every so often.
In the code, just above the line, I have the line to get the on hand quantity, which it does take correctly (I used xltypevisible to paste values for this field, but that is only because I wanted a sum of the results and this was the only way I knew). It's only this stocking type column which shows wrong values randomly.
Any ideas?
Thanks!
1)
Cells(i, 1) = i - 4
as it is written , it refers to perporig.Cells(i, 1)
is this what you want?
2)
perporig.Sheets("perpetual").Range("A3:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
would filter from row 3, while you have headers in row 4 and data from row 5 downwards
change it to
perporig.Sheets("perpetual").Range("A4:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
3)
what do you think is Counter doing? Not certainly count visible rows only
Credits to findwindow, I found the answer. The .cells(cells()) part didn't have the correct sheet reference for the inner cells():
Instead of
x = perporig.Sheets("perpetual").Cells(Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
I used this:
With perporig.Sheets("perpetual")
x = .Cells(.Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, .Cells(RowLast + 1, 1).End(xlUp).Row
End With
And it worked.
Thanks for your help!