Merging-Copy Row-Marking Solved...

[ssafiri]

I want to mark my solved threaded by ?Solved?. How can I do this?

As I said I?m a beginner in VB in excel and this may trouble you also I search many threaded here but I couldn?t find my answers.

1-As attached file, I want to do 2 jobs. First, delete all blank rows between rows 5 and 15. And also copy remaining rows (i.e. 6 Rows: AAA to XXX) to sheet 2. Consider that row maybe in 2 rows and some times in 13 rows. It is dependent.
How can I do this? I put a code but it doesn?t work at all.
And how can I do this without deleting blank rows? (I mean directly copy rows into a sheet with considering various numbers in rows).

2-When I Push ?Merge Error? button I gets an error that ?The selection contains multiple data values. Merging into one cell will keep the upper-left most data only.? How can omit this alert message?

3-As we see in ACCESS there are a useful tools and format for pre default ?List Box? for example we can pre define: ?_..._... . I mean we can put _ for separating data when we enter a data. Is it possible to define such things in VB Macro and Excel Userforms?

4- How can we zoom in or out to all entire our works in a worksheet? I mean if we put a data in row 50, the Work sheet automatically zoom up to row50?



Thanks to all.

[lucas]

That's a lot of questions for one thread but I will try to answer one or two of them for you.
You can mark your thread solved using thread tools at the top of the page.

Question 2: I would avoid merged cells if possible....try this as an alternative.
[VBA]Public Sub Button1_Click()
Range("H16").Select
ActiveCell.Value = "<<MERGED CELL"
With Range("A16:G16")
.Font.Bold = True
.Font.Size = 18
.EntireRow.AutoFit
.Cells.Interior.Color = RGB(363, 180, 196)
.Value = "ERROR OCCUR HERE"
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
End With
End Sub[/VBA]
note the change in red.

[lucas]

Question 1 (first part about deleting blank rows)
this will delete all rows that are blank or have a 0 in column A1:A5
[VBA]Option Explicit
Sub RemoveBlanks()
Run "RemoveBlanksSelect", 1, "A1:A5"
End Sub

Sub RemoveBlanksSelect(i As Long, Addy As String)
Dim Rng As Range
Dim MyCell
Dim c
Set Rng = Sheets(i).Range(Addy)
With Rng
Set c = .Find(0, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
Do
c.ClearContents
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub[/VBA]

[Erdin? E. Ka]

Hi ssafiri,

Here is a sample for copy-deleting;

[vba]Sub DeleteAndShiftUpEmptyCells()
Dim CeL As Range
Dim IsZero As Integer
Dim CountOfProcess As Integer
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
S1.Activate
CountOfProcess = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
ReWork:
For Each CeL In Range("A1:A" & CountOfProcess)
If CeL = Empty And CeL.Offset(0, 1) = Empty Then
Range(Cells(CeL.Row, 1), Cells(CeL.Row, 2)).Delete Shift:=xlUp
CountOfProcess = CountOfProcess - 1
End If
Next
IsZero = WorksheetFunction.CountBlank(Range("A1:A" & CountOfProcess))
If IsZero = 0 Then GoTo SkipToCopy
If IsZero <> 0 Then GoTo ReWork
SkipToCopy:
Last = WorksheetFunction.CountA(Range("A:A"))
Range(Cells(1, 1), Cells(Last, 2)).Copy
S2.Activate
S2.Paste
End Sub[/vba]

And this one for copy but no deleting;

[vba]Sub CopyAllDataWithOutDeleting()
Dim i As Integer
Dim j As Integer
Dim CountOfProcess As Integer
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
j = 1
CountOfProcess = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
For i = 1 To CountOfProcess
If S1.Cells(i, 1) <> "" Then
S2.Cells(j, 1) = S1.Cells(i, 1)
S2.Cells(j, 2) = S1.Cells(i, 2)
j = j + 1
End If
Next
End Sub[/vba]

This codes for don't getting any error messages:
[vba]

Application.DisplayAlerts = False
... your codes
...
...
Application.DisplayAlerts = True

[/vba]

My opinion for your third question: I'm not good at ACCESS and still i am studing on. Therefore i don't want to tell you something. It's should be better for you that waiting for an answer from an expert.

And for your fourth question: You can use this codes for zoom, but maybe that's couldn't be convenient for your request.

In sheet's code page:
[vba]Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A50" Then ActiveWindow.Zoom = 200
End Sub[/vba]

However, you can use "Camera" method for this if it is suitable for you.

[mdmackillop]

Hi Erdinc
It's simpler to delete rows if you start from the bottom
[vba]
For i = CountOfProcess To 1 Step -1
If Cells(i, 1) = Empty And Cells(i, 2) = Empty Then
Cells(i, 1).EntireRow.Delete
End If
Next
[/vba]

[Erdin? E. Ka]

Hi Erdinc
It's simpler to delete rows if you start from the bottom...

Hi Malcolm,

You are right, my first code example was too long, but your code is shortest. I had already regretful to send my first example. And for that i wished to sent a new one, then i re-openden this thread, then i wrote my newest codes instead of that but, these are also too long anyway. And finally i saw your shortest example. So, i have to thank you for useful tip.

By the way, my newest codes:

[vba]
Sub DeleteEmptyRows()
NoRow = Range("A1:A15").Rows.Count
LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
FirstRow = LastRow - NoRow + 1
Application.ScreenUpdating = 0
For R_o_w = LastRow To FirstRow Step -1
If Application.WorksheetFunction.CountA(Rows(R_o_w)) _
= 0 Then Rows(R_o_w).Delete
Next
Application.ScreenUpdating = 1
End Sub
[/vba]

So, i should think about some cross-ways for reach for better solutions!! There is no end of learning.

[mdmackillop]

This is what I would say is the simplest/shortest way
[vba]
Sub DeleteAndShiftUpEmptyCells()
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Application.WorksheetFunction.CountA(Cells(i, 1).EntireRow) = 0 Then
Cells(i, 1).EntireRow.Delete
End If
Next
End Sub

[/vba]