Free Microsoft Excel 2013 Quick Reference

vba code: if cell not empty cut paste data

Hi,

I have a data set (65536 rows) and need code to find not empty cells in column E, if a not empty cell is found it needs to cut the data in that row from column C to G and paste it in Column E in that same row, then go to next not empty cell and do same. Any help greatly appreciated.


Post your answer or comment

comments powered by Disqus
hello
i am working on a spreadsheet and i have cells that i want them to have formula in them if they are empty

for example i want to make this happen
If G2 is empty then G2 =Sum(K1:K3)

please help

I have programmed in many languages but a noob when it comes to VBA. I can guess at the syntax but I don't really understand what I am doing. So I was wondering if the following is possible.

I want to write a script that checks for a value on a different sheet (SheetA) and based on it being defined (ie not empty) copies the entire row to a different sheet (SheetB). I probably have around 120 rows in SheetA and will only expect to see 10-20 rows on SheetB based on the criteria for copying. I am also unsure if the VBA code should be for SheetA or SheetB.

At first I thought I could just hide rows based on a value but I also need to export the sheet to a csv file and looks like excel exports all the rows, even the hidden ones and I don't want that.

Hi All,
I have the following code in a workbook which copies all the data from several worksheets onto one. The code works fine until somebody changes the quote, quote (1), etc names on the worksheet tabs. Is there a way of automatically updating the vba code if the worksheet name changes.

Thanks


	VB:
	
 Copy_to_quote() 
     '
     
     
     'Quote
    Sheets("Client Quote").Select 
    Range("A15:C65000").Select 
    Selection.ClearContents 
     
    Sheets("Quote").Select 
    Range("Y1:Z1").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 3, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote").Select 
    Range("Y2:Z7").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote").Select 
    Range("B30:D6000").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
     'Quote (2)
     
    Sheets("Quote (2)").Select 
    Range("Y1:Z1").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 6, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote (2)").Select 
    Range("Y2:Z7").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote (2)").Select 
    Range("B30:D6000").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
     'Quote (3)
     
    Sheets("Quote (3)").Select 
    Range("Y1:Z1").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 6, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote (3)").Select 
    Range("Y2:Z7").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
    Sheets("Quote (3)").Select 
    Range("B30:D6000").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("A65536").End(xlUp).Row).Count 
    Cells(myRow + 2, 1).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
     'Terms & Cond
    Sheets("Terms & Conditions").Select 
    Range("b1:b57").Select 
    Application.CutCopyMode = False 
    Selection.copy 
    Sheets("Client Quote").Select 
    myRow = Range("B1:B" & Range("B65536").End(xlUp).Row).Count 
    Cells(myRow + 4, 2).Select 
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _ 
    False, Transpose:=False 
     
     
     
     
     
     
     
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I need help with excel formula. I am a newbie. Any help or suggestion will be highly appreciated:

I have a spreadsheet with 5 cell name CellA, CellB, CellC, CellD, CellE...

I want CellE to be auto filled with unique five figure random numbers if CellA is not empty or if any value greater then 0 is added.

Thanks in advance.

Hey all,
I am trying to have conditional formatting of cells apply only if another cell is blank in 2007.

A3 has a formatting of =MOD(ROW(),2)=1, then =AND(A3<>"",A3+15<=$G$1) to change the color based on date and finally =AND(A3<>"",A3+30<=$G$1) to again change the color again by date.

What I would like to do is for the cells in columb A to change only if corresponding columb B cell is empty, without using macros if possible.

Hi, I wonder if any-one could help. I have a script to save each row in an excel file as a text file. This works fine, but I now want it to ignore a column if there is no data in it, rather than show the heading and a blank field.
So if cell a is blank, then go to cell b etc...

The part of the script I want to edit is:

FileNum = FreeFile
With wks
For iRow = 1 To .Cells(.Rows.Count, "e").End(xlUp).Row
Close #FileNum
Open myFolderName & .Cells(iRow, "e").Value For Output As FileNum
Print #FileNum, myHeader, .Cells(iRow, "a").Value
Print #FileNum, myHeader2, .Cells(iRow, "b").Value
Print #FileNum, myHeader3, .Cells(iRow, "c").Value
Print #FileNum, myHeader4, .Cells(iRow, "d").Value
Print #FileNum, myHeader5, .Cells(iRow, "e").Value

Next iRow
End With

Any help would be appreciated.

Many Thanks.
Louise

IS IT possible by VBA code---

If cell f5 of sheet "BS" ="Yes", hide sheet "D".

I want it as AUTO i.e if Cell f5 of sheet "BS" is "YES" , it will automatically hide sheet D.

I need to create a macro that will find the data basis criteria and then cut and paste the entire data into another sheet.

Example the Sampel data attached contains a file. I would like to get a help on a macro that will Search for any occurance of word "Summary" in Sheet1 if found then from first low till that Summary ocuurance cut the entire data and paste it in new sheet. Then again start seraching for summary word if found again then cut the data from first row (remember this time it start picking data from next row of first summary occurance) till summary needs to cut paste in new sheet and so on. All the blank rows before first record needs to be deleted.

If possible then name the new worksheets basis the summary type. for example first wud be "Summary Receivable" and second "Summary Payable".

Thanks in Advance for any help if i can get onto it.

Regards,

Hi guys.

I need little bit help to make a long code shorter if possible.
Code itself does the following: If cell is not empty then it moves data from one column to another column (to its respective row). I'm using a method or code that I have used in past which it works great but this time I need to do it with nine columns and the code looks rather long as I do not know how to make it shorter.

Please see the code below:

Sub move_data_from_one_column_to_another()
Application.ScreenUpdating = False
Call AB_to_I
Call AC_to_J
Call AD_to_K
Call AE_to_L
Call AF_to_M
Call AG_to_N
Call AH_to_O
Call AI_to_P
Call AJ_to_Q
Application.ScreenUpdating = True
End Sub



Sub AB_to_I()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AB") <> "" Then
        Cells(RowCtr, "I").Value = Cells(RowCtr, "AB").Value
    End If
Next RowCtr
End Sub

Sub AC_to_J()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AC") <> "" Then
        Cells(RowCtr, "J").Value = Cells(RowCtr, "AC").Value
    End If
Next RowCtr
End Sub

Sub AD_to_K()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AD") <> "" Then
        Cells(RowCtr, "K").Value = Cells(RowCtr, "AD").Value
    End If
Next RowCtr
End Sub

Sub AE_to_L()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AE") <> "" Then
        Cells(RowCtr, "L").Value = Cells(RowCtr, "AE").Value
    End If
Next RowCtr
End Sub

Sub AF_to_M()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AF") <> "" Then
        Cells(RowCtr, "M").Value = Cells(RowCtr, "AF").Value
    End If
Next RowCtr
End Sub

Sub AG_to_N()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AG") <> "" Then
        Cells(RowCtr, "N").Value = Cells(RowCtr, "AG").Value
    End If
Next RowCtr
End Sub

Sub AH_to_O()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AH") <> "" Then
        Cells(RowCtr, "O").Value = Cells(RowCtr, "AH").Value
    End If
Next RowCtr
End Sub

Sub AI_to_P()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AI") <> "" Then
        Cells(RowCtr, "P").Value = Cells(RowCtr, "AI").Value
    End If
Next RowCtr
End Sub

Sub AJ_to_Q()
Dim RowCtr As Double
Dim LastRow As Double
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For RowCtr = 2 To LastRow
    If Cells(RowCtr, "AJ") <> "" Then
        Cells(RowCtr, "Q").Value = Cells(RowCtr, "AJ").Value
    End If
Next RowCtr
End Sub
The code is still efficient and performance wise its ok. But if someone know how to make it shorter that would be nice to know.
I have attached spreadsheet that has the code and it has sheets Before and After. just hit the macro button "Run Code".

Any help is appreciated
Cheers).Value = Cells(RowCtr,AJ

Hi

I've got 2 named ranges, "IncomeSum", which ranges from D5 to the last used cell in column D, and "IncomeCumulative", which ranges from E5 to the last used cell in column E.

I would like to check "IncomeSum" for non empty cells.

If the cell contains something other than "" or 0, I would like to paste a formula in the cell immediately to the right (in column E).

This fomula should be copied from the last previous formula in "IncomeCumulative".

I think I need to create a loop in VB using the Private Sub Worksheet_Calculate method, but I'm not sure how to do that in this instance.

Would appreciate any help.

Many thanks

Pete

I started on this but really became stumped and I thought rather than pulling my hair out I should get professional help!

The excel file contains a number of Sheets which are for parts of a machine (more will be added later - so this needs to be able to grow). The first sheet has a combo box to get input, the VBA then gets the correct sheet and cut/pastes the info to the front sheet for viewing. My problem is there is more than one part so I created a list of all sub assemblies that make up the part which have to be listed under the first lot of information - this in turn may have more sub assemblies under it which also have to be displayed etc etc

I have the information of the sub assemblies listed in a sheet similar to this:

Cubicle : CubicleSheet : Housing : Seals
Motor: MotorSheet : Housing : Terminal : Wires : Screws
Wires: Wiresheet
Screws : Screwsheet
Terminal : TerminalSheet
Housing : Housing
Seals : SealsSheet : Gaskets

From the data above I need capture the user input (Done - combo box) and go to the correct row (Done), get the infomation on the high level part (held in relevant sheet) and display on the first Sheet (Done). I then need to get all the sub-assemblies (cells to the right of this cell) and display their information under the first one on the first sheet (Not Done).

Now here is where it gets tricky (view data above) if we go to "Cubicle" get the data and put it on the front sheet, then read the next cell "Housing" and then get that data and display it on the front sheet under the first, we move to next cell "Seals" we put that on the front sheet under the second lot of information BUT it ALSO has subassemblies "Gaskets" (I am really struggling to explain this correctly I feel) and this will need to be placed under "seals" info on the first sheet.

Basically the objective is to create a library of "subassemblies" which when combined together make the larger part and all the information associated with those parts are in a handy little one sheet.

My code is no doubt terrible and I have only gotten a small way through - it is cut/paste from samples and part macro but it does the job for the first bit.

	VB:
	
 Checker() 
    Dim Name As String 
    Dim NameA As String 
    Dim TabName As String 
    Dim sData As Range 
    Dim targetRng As Range 
     
     'Application.ScreenUpdating = False
    Name = Cells(1, 13) 
    Name = Name - 1 
    Sheets("Coder").Select 
    Worksheets("Coder").Range("A1").Offset((Name), 0).Select 
    NameA = ActiveCell 
    ActiveCell.Offset(0, 1).Select 
    TabName = ActiveCell 
     ' Get all cells with data on this row - subassemblies
     ' Check if the subassemblies have subassemblies if no get data from relevant sheet and display under previous entry on
first sheet
     ' If yes get all cells with data in the row - sub-subassemblies
     ' Check if the sub-subassemblies have subassemblies if no get data from  relevant sheet and display under previous entry
on first sheet
     'If yes etc etc you get the idea - I am certain there is a more elegant way to do this but I was just trying to explain
it
    Sheets("Main").Select 
    Worksheets("Main").Range("K2").End(xlDown).Offset(1, 0).Value = NameA 
    Worksheets("Main").Range("K2").End(xlDown).Font.Bold = True 
    Set sData = Worksheets(TabName).Range("K2:DP100") ' " & Range("K2").End(xlDown).Row) Need to fix
    Set targetRng = Worksheets("Main").Range("K3").End(xlDown).Offset(1, 0) 
     
    sData.Copy Destination:=targetRng 
    Sheets("Main").Select 
     'Application.ScreenUpdating = True
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Code has to be flexible enough to handle more Tables (if i add more to the hierarchy at the bottom) or if more sub assemblies, sub sub assemblies, sub sub sub subasselmblies are added etc etc.

I tried to get the file small enough to post here but it seems to be 1.5MB and I am not sure why - does not contain much information at the moment - I can send the file via email if requested

Hi,

I have recently added this code to a workbook to prevent users from cut/pasting data in a worksheet

Private Sub Workbook_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Range)

If Application.CutCopyMode = xlCut Then
Application.CutCopyMode = False
End If

End Sub

Although users cannot cut/paste they can still drag and drop which is in effect exactly the same as cut/paste. I added to the code - Application.CellDragAndDrop = False.

This prevented users from drag/drop but proved a pain because it not only disabled it for the workbook in question but also from excel. Is there any way round this??

Also I would still like to be able to drag/fill as this would be used often when updating the training plan.

Basically I would like to restrict users from cut/paste and drag/drop, but allow copy/paste and drag/fill.

I have attached the workbook, which is a training plan for my elite athletes to complete. BTW the reason for the code is that when users cut/paste it ruins all the CF formulas I have created. Am new to excel (but totally addicted) so any help would be greatly appreciated.

Many Thanks
Col

I need some vba code for my macro that checks if cell "G1" is empty.

If the cell is not empty I don't want the macro to do anything more.

If G1 is empty. Then I want the macro to insert a blank column between the B and C columns so the content of F1 is moved to G1 and the content of the C-column is moved to the D-column instead.

Hope for some help....

the VBA code below is suppose to take existing data from the worksheet and auto-fill the form in order for the user to make changes. Once the changes are made, the user is to click an "Update" button to re-insert the data back into the row where the data came from.

When executing the form on the existing row of data, the form is auto-filled with the existing data as expected, but when I make changes to the existing data, it does not put the data back into the row where it came from.

Also, On the user form, there is a text box that allows the user to enter a date. I would for the date textbox to automatically enter today's date when the user clicks on an empty cell in column A.

Can you assist me with altering this code to accomplish the above?

Private Sub UserForm_Initialize()
With ActiveCell
If .Value = vbNullString Then
With .Parent
Set myCells = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Else
Set myCells = ActiveCell.EntireRow.Range("A1")
End If
Set myCells = myCells.Resize(1, 28)
End With
Call FromSheetToUserform
Me.txtTYPE.SetFocus
End Sub

Sub FromSheetToUserform()
Dim myData As Variant

myData = Application.Transpose(Application.Transpose(myCells.Value))

With Me
.txtDATE.Text = CStr(myData(1))
.txtTYPE.Text = CStr(myData(2))
.txtIDENT.Text = CStr(myData(3))
.txtROUTE.Text = CStr(myData(4))
.txtTOTAL.Text = CStr(myData(5))
.txtSEL.Text = CStr(myData(6))
.txtMEL.Text = CStr(myData(7))
.txtSES.Text = CStr(myData(8))
.txtOPT1.Text = CStr(myData(9))
.txtOPT2.Text = CStr(myData(10))
.txtOPT3.Text = CStr(myData(11))
.txtOPT4.Text = CStr(myData(12))
.txtOPT5.Text = CStr(myData(13))
.txtDAY.Text = CStr(myData(14))
.txtNIGHTLDG.Text = CStr(myData(15))
.txtNIGHT.Text = CStr(myData(16))
.txtIMC.Text = CStr(myData(17))
.txtSIM.Text = CStr(myData(18))
.txtAPPCH.Text = CStr(myData(19))
.APPCHTYPE.Text = CStr(myData(20))
.txtFLTSIM.Text = CStr(myData(21))
.txtXCTRY.Text = CStr(myData(22))
.txtSOLO.Text = CStr(myData(23))
.txtPIC.Text = CStr(myData(24))
.txtSIC.Text = CStr(myData(25))
.txtDUAL.Text = CStr(myData(26))
.txtCFI.Text = CStr(myData(27))
Rem code
.txtREMARKS.Text = CStr(myData(28))
End With
End Sub

Private Sub CommandButton1_Click()
With Me
If .txtDATE.Text = vbNullString Then
MsgBox "Please enter a DATE"
.txtDATE.SetFocus
Else
myCells.Range("A1").Select
Call FromUFormToSheet
Call clearTextBoxes: Rem not needed if form is to be unloaded
Unload Me
End If
End With
End Sub

Sub FromUFormToSheet()
Dim myData() As String
ReDim myData(1 To myCells.Cells.Count)

With Me
myData(1) = .txtDATE.Text
myData(2) = .txtTYPE.Text
Rem code
myData(28) = .txtREMARKS
End With

myCells.Value = myData
End Sub

Sub clearTextBoxes()
Dim xControl As Object
For Each xControl In Me.Controls
If TypeName(xControl) = "TextBox" Then
xControl.Text = vbNullString
End If
Next xControl
End Sub

Sorry, lots of questions again today...

I have this code that should stop a user from printing a worksheet if the following cells are empty...but it still allows printing. Not sure what's wrong.

These cells are mandatory:
B3:B6
D5
H3:H6

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    
    Dim rngRangeToCheckBeforePrinting As Range
    Dim rngCell As Range
    
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngRangeToCheckBeforePrinting = Application.Union(.Range("B3"), .Range("B4"),
.Range("B5"), .Range("B6"), .Range("D5"), .Range("H3"), .Range("H4"),
.Range("H5"), .Range("H6"))
        For Each rngCell In rngRangeToCheckBeforePrinting
            If IsEmpty(rngCell) Then
                Cancel = True
                MsgBox "Please ensure that '" & Replace(rngCell.Address, "$", "") &
"' is not empty.", vbOKOnly + vbInformation, "Unable to print"
                Exit For
            End If
        Next rngCell
    End With
    
    Set rngRangeToCheckBeforePrinting = Nothing
    Set rngCell = Nothing
    
End Sub


I'm trying to write some code in a macro that will check to see if cell C5 is empty, if so, move to the the next available empty cell in that row, and paste a specific value from the SXS Output sheet.

I've attached a test file for clarity. I have two modules in this workbook. I'm using module 2 for testing the code. Thanks in advance for any help you can offer.

Regards,

-gshock

=IF((R5=1),IF((J6<31),J6+1,IF((J6<28),J6+1,"")))

I am wanting to check the value in cell R5. If it is a 1 I want to then check if J6 is less than 31. If both cases are true, I then want J6+1. This will be the currents cell value, for example J7 now has the value of (J6+1).
That part works, but what I also want to happen is that if R5 <> 1, that we will check to see if J6 is less than 28 and then add 1 to it J6+1.
This second part does not work. I am hoping someone can show me how the else or false part of this will work the way I want it to.

If it can not be done this way, maybe you can then help me with the vba code instead. I tried to put this into an if then, but for some reason when I put a second if then inside the first set of if then, excel locks up. I have tried multiple ways and excel locks up unless I leave only one if then inside the change sub. I am guessing I can only have one until someone lets me know otherwise.

Thanks you in advance.

Hi,

Am accessing the website using the below code. I have an issue if i mention visible=false in the code.The code is working perfectly if we set visible=true. I tried a lot but i couldn't get the value of html tables. It doesn't throw any error when i run the tool but sometimes it shows excel is busy with some other operations. The window should not be open each and every time to fetch the value from the website. It would be great if someone give an idea to resolve this issue.


	VB:
	
 ie = CreateObject("InternetExplorer.Application") 
 'Call FindSolverexcel
 'Set wshShell = WScript.CreateObject("WScript.Shell")
 'Set oWshShell = CreateObject("WScript.Shell")
With ie 
    .Visible = False 
    .Navigate "https://website-name/login.asp" 
    .Top = 0 
    .Left = 0 
    .Height = 0 
    .Width = 0 
     
     ' Loop until the page is fully loaded
    Do Until Not ie.Busy And ie.readystate = 4 
        DoEvents 
    Loop 
     ' Make the desired selections on the Login web page and click the
     ' submit Button
     
    Set ipf = ie.Document.all.Item("username-id") 
    ipf.Value = "test" 
    Set ipf = ie.Document.all.Item("pwd-id") 
    ipf.Value = "pass" 
    ie.Document.all.Item("Login").Click 
     ' Loop until the page is fully loaded
    Do Until Not ie.Busy And ie.readystate = 4 
        DoEvents 
    Loop 
End With 
 
With ie 
    intRow = intRow + 1 
     'col = col + 1
    cells = Sheet1.cells(intRow, 1).Value 
     'MsgBox (cells)
     
    If cells  "" Then 
         
        .Visible = False 
        .Navigate "https://nextscreen.asp" 
        .Top = 0 
        .Left = 0 
        .Height = 0 
        .Width = 0 
    End If 
     
End With 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi i am creating this excel spreadsheet form for my clients to fill out. i need a macro for it to check certain cells and if they are empty then hide the row in the range. I have this up to now and it does work but i have to run the script manually myself in the VBA and not automaticly.

Any help is appreciated!

Sub HideRows()

Application.ScreenUpdating = False

Dim cell As Range
For Each cell In ActiveSheet.Range("B33:B46,B53,B63:B64,B77:B79,B100:B103,B111:B116,B136:B139,B172,B204:B215,B231:B232,B238")
If cell.Value = "" Then
cell.EntireRow.Hidden = True
Else: cell.EntireRow.Hidden = False
End If
Next

End Sub

Hey guys I was running down through my code and I just realized I have a mistake. In certain row I have several blanks and then a formula that returns a blank depending on the value of previous cells. However Im using the next line of code to get the length of my row:


	VB:
	
iColumn = ws1.Cells(row, Columns.count).End(xlToLeft).Column 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This code returns the last empty cell not the blank one. could you guys help out how to work around this.

many thanks!!

Hello all,

I am turning to this forum again looking for an answer. What I am trying to do is: I have two worksheets; “owssvr” which is my query and “Sheet2” where I need to display report.
In “Sheet2” Column E1, I have Factory Name that I would type in. Based on that requirement, I would need to parse data from “owssvr” sheet amongst the columns in “Sheet2”.
For example, if “Sheet2” column E1=NZ Factory, I need macro that would look in “owssvr” sheet (column “C”) and return Item Name from column “B” from the same sheet to the “Sheet2” Cell “K2” based on my requirement. If there is more than 1 item name, it would enter next item name in cell “N2” and so on. Then I would need “Phase 1 T 1 Average Score” from “owssvr” to be copied to “Sheet2” cell “K4” and then again if there is more than 1, it would enter next Average score in cell “N4” and continue the same way for the scores.

I have started with this code (it only does the Item Name and Average score) which copies correct items and average scores to the cells “K2” and “K4”. I have problem moving data to the cells “N2” and “N4”. I have attached sample workbook to help visualize what the “Sheet2” should look like.
Here is the code I have:

	VB:
	
 GetMatches3() 
    Dim PartRngowssvr As Range, PartRngSheet2 As Range 
    Dim lastRowowssvr As Long, lastRowSheet2 As Long 
    Dim cl As Range, rng As Range 
    lastRowowssvr = Worksheets("owssvr").Range("C65536").End(xlUp).Row 
    Set PartRngowssvr = Worksheets("owssvr").Range("C2:C" & lastRowowssvr) 
    lastRowSheet2 = Worksheets("Sheet2").Range("E65536").End(xlUp).Row 
    Set PartRngSheet2 = Worksheets("Sheet2").Range("E1:E" & lastRowSheet2) 
     
    For Each cl In PartRngowssvr 
        For Each rng In PartRngSheet2 
            If (cl = rng) Then 
                Range("K2").Offset(0, 0) = cl.Offset(0, -1) 
                Range("K4").Offset(0, 0) = cl.Offset(0, 2) 
                 'rng.Offset(0, 2) = cl.Offset(0, -1)
                 
            End If 
        Next rng 
    Next cl 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I know my problem is here

	VB:
	
Range("K2").Offset(0, 0) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
but I don't know how to tell macro if cell “K2” is not empty, move 3 cells to the right and if that cell is not empty, move again 3 cells to the right and so on.

I hope there is someone out there that can help with this.

Thank you

Hello!
I have two macros one of which imports the data and the other processes the data. These macros were created at different times and need to be joined into a single macro that will combine their operations – with slight modification to the importing macro. Let me describe what each of the macros does:

PROCESS macro:
Cycles through the CONTROL CELL on the “1” tab using the VALUES TO TEST. For each value to test it copies the values form the output tabs and pastes them into the A+B tab. Then it removes the duplicate rows there.

	VB:
	
 
 '======================================
Sub PROCESS() 'This subroutine is called when clicking on the first button
    Dim i As Long, j As Long, k As Long 'Those are the variables that will browse through the whole sheets
    Dim l As Integer 'this will be used to browse through the values to test
    Dim TheSearch(1 To 2) As Object 'This is an array of objects that will be used for the search
    Dim TheRange As Range 'This will be used to flag the range of duplicates in the output
     
     'Searching for the Text string 'VALUES To TEST' in the sheet "1" in order to know where the array of values to be tested
start
    Set TheSearch(1) = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count + 10,
ActiveSheet.UsedRange.Columns.Count)).Find(What:="VALUES TO TEST", LookIn:=xlValues, Lookat:=xlWhole) 
     
     'If this search returned something then the references are defined
    If Not TheSearch(1) Is Nothing Then 
         
         'We further look the same way for the reference cell
        Set TheSearch(2) = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count + 10,
ActiveSheet.UsedRange.Columns.Count)).Find(What:="CONTROL CELL", LookIn:=xlValues, Lookat:=xlWhole) 
         
         'If this second search returned something, we have all references defined and may start the work
        If Not TheSearch(2) Is Nothing Then 
             
             'This is the loop to go through all all values: as long as the cell below TheSearch(2).Row are non-empty it
means that there is a value to test
            l = 1: While Trim(Cells(TheSearch(1).Row + l, TheSearch(1).Column))  "" 
             
             'Put the value to be tested in the control cell
            Cells(TheSearch(2).Row + 1, TheSearch(2).Column) = Cells(TheSearch(1).Row + l, TheSearch(1).Column) 
             
            Application.Calculation = xlManual 'Disable automatic calculation of the cells: the cells with Rand() won't
change value. Necessary to avoid continuously re-evaluating the cells and slowing down everything.
            Application.Calculate 'Evaluate once all formulas in the cells
            Application.ScreenUpdating = False 'Disable the refresh of the screen so that the user won't see the switching
between all sheets and so on
             
             'Find the data already present in sheet A+B: as long as the cells in the first column are non-empty, we increase
the counter "k" by one unit until we have found a blank cell. In this case the number of rows equals "k".
            k = 1: While Trim(AB.Cells(k, 1))  "": k = k + 1: Wend 
             
             'Copy data from A OUT
            AOUT.Select 'select the sheet "A OUT" - I have renamed the code of the sheet to "AOUT" so that this line is
equivalent to Sheets("A OUT").Select
            i = 1: While Trim(Cells(i, 2)) = "A": i = i + 1: Wend: i = i - 1 'Same as previously described: count the number
of used rows in sheet "A OUT" with a simple loop. In this case even in some rows are non-empty, we need to find out how many
cells get evaluated, which can be done with the condition that cells of the second column = "A"
            If i > 0 Then 'If there is at least one line of data - to avoid an error in the declaration below
                Range(Cells(1, 1), Cells(i, 13)).Copy 'Select and copy to clipboard the range that get evaluated, i.e. in
your sheet you have 14 columns starting from column 1, and i rows starting from row 1.
                AB.Select: Range(Cells(k, 1), Cells(k + i, 13)).Select: Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'Go to the sheet "A+B" (whose code I renamed to "AB"), select the
destination area (it has the same range as the area selected in the previous sheet), and paste as text - do not paste
everything since we do not want to paste the formulas, only the values.
            End If 
             
             'Copy data from B OUT
            BOUT.Select 'Exactly the same as above for "A OUT"
            j = 1: While Trim(Cells(j, 2)) = "B": j = j + 1: Wend: j = j - 1 
            If j > 0 Then 
                Range(Cells(1, 1), Cells(j, 13)).Copy 
                AB.Select: Range(Cells(k + i, 1), Cells(k + i + j, 13)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False 'Only difference here is that we have already pasted "k+i" lines of data (instead of "k"
previously), so that we shall paste the new lines after those "k+i" lines
            End If 
             
             'End
            S1.Select 'Go back to the sheet "1" (whose code I renamed to "S1"
            Application.Calculation = xlAutomatic 'enable automatic calculation of the cell (if not you may close Excel and
further forget you had disabled automatic calculation and get into some trouble)
            Application.ScreenUpdating = True 'Update the screeen refreshing
            l = l + 1 'Increase the counter for the data to be tested
             
        Wend 
         
         'Check for duplicate lines in "A+B" and erase them
        Application.Calculation = xlCalculationManual 'Again, avoid automatic calculation
        Application.ScreenUpdating = False 'Again, avoid refreshing screen
        Set TheRange = Nothing 'Initializing the range of dupes to nothing
        With AB 'with the sheet of code "AB" - averything that refers to a WITH statement comes fir a dot "." first
             'Very slow routine that is quadratic in the number of lines - if you want to increase the speed you may have to
use some tricks as hinted in the post by Colin
            i = 1: While Trim(.Cells(i, 1))  "" 'browsing all non-empty lines in the A+B sheet
            j = i + 1: While Trim(.Cells(j, 1))  "" 'for each line "i", looking for potential dupes that will come after line
i - it is necessary to go on after line i because if not all duplicate lines would be removed, including the original copy
            If .Cells(i, 1) = .Cells(j, 1) And .Cells(i, 2) = .Cells(j, 2) And .Cells(i, 13) = .Cells(j, 13) Then 'Those are
the conditions defining a duplicate line: same cells in columns 1, 2, and 14 (last column)
                If TheRange Is Nothing Then 'This IF condition is necessary to avoid using UNION command with a range that is
set to NOTHING (would produce an error)
                    Set TheRange = .Range(j & ":" & j) 'First dupe found: the range of dupes is defined by this only row
                Else 
                    Set TheRange = Union(TheRange, .Range(j & ":" & j)) 'otherwise if some dupes were already found, the
range of dupes consists of the union of the new row with the previously found ones
                End If 
            End If 
            j = j + 1 'Increasing the counter for the dupes after line i
        Wend 
        i = i + 1 'Increasing the counter for the browsing of all lines in the output sheet
    Wend 
    If Not TheRange Is Nothing Then TheRange.EntireRow.Delete 'If we have found a dupe, then we erase all rows containing the
dupe - much faster to use this range command than erasing each line indivisually on the fly
End With 
S1.Select 'select again the main sheet "1"
Application.Calculation = xlAutomatic 'Enabling again automatic calculation
Application.ScreenUpdating = True 'Enabling again the refreshing of the screen
 
 'Finished the test: displaying a message to show that all "l-1" values were tested
MsgBox ("Done: all " & l - 1 & " values were tested and eventual duplicates removed.") 
 
 'did not find the reference cell: displaying a message such that there was an error
Else 
    MsgBox ("Could not find the string 'CONTROL CELL'.") 
End If 
 
 'did not find the values to test: displaying a message such that there was an error
Else 
    MsgBox ("Could not find the string 'VALUES TO TEST'.") 
End If 
End Sub 
 '======================================
Sub EraseAB() 'This subroutine is called whenclicking on the second button
    AB.Cells.ClearContents 'erase all contents of the sheet "A+B" (whose code I renamed to "AB")
End Sub 
 '======================================

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
IMPORT macro:
Imports the text from a specified folder and records the average of the last column along with the name of the text file. I need it to be plugged into the PROCESS macro with slight modification = it should import these text files into the A19 cell on the 1 tab and enter the name of the text file into the B17 cell on the same tab.

	VB:
	
 IMPORT() 
    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim txtFile As Object 
    Dim writeToRow As Integer 
    Dim rn As Range 
    Dim myAverage As Double 
    writeToRow = 2 
    Worksheets(1).Cells(1, 1) = "File Name" 
    Worksheets(1).Cells(1, 2) = "Average Value" 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.GetFolder("C:MyTemp") 
    For Each txtFile In objFolder.Files 
        Worksheets.Add before:=Worksheets(1) 
        Worksheets(1).Name = txtFile.Name 
        With Worksheets(1).QueryTables.Add(Connection:="TEXT;" & txtFile.Path, _ 
            Destination:=Range("A1")) 
            .FieldNames = True 
            .RowNumbers = False 
            .FillAdjacentFormulas = False 
            .PreserveFormatting = True 
            .RefreshOnFileOpen = False 
            .RefreshStyle = xlInsertDeleteCells 
            .SavePassword = False 
            .SaveData = True 
            .AdjustColumnWidth = True 
            .RefreshPeriod = 0 
            .TextFilePromptOnRefresh = False 
            .TextFilePlatform = 850 
            .TextFileStartRow = 1 
            .TextFileParseType = xlDelimited 
            .TextFileTextQualifier = xlTextQualifierDoubleQuote 
            .TextFileConsecutiveDelimiter = True 
            .TextFileTabDelimiter = False 
            .TextFileSemicolonDelimiter = False 
            .TextFileCommaDelimiter = False 
            .TextFileSpaceDelimiter = True 
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1) 
            .TextFileTrailingMinusNumbers = True 
            .Refresh BackgroundQuery:=False 
        End With 
        Set rn = Range("F1", Range("F1").End(xlDown)) 
        Worksheets(1).Cells(1, 8) = "Average" 
        Worksheets(1).Cells(1, 9).Formula = "=AVERAGE(" & rn.Address & ")" 
        Worksheets(2).Cells(writeToRow, 1) = txtFile.Name 
        Worksheets(2).Cells(writeToRow, 2) = Round(Worksheets(1).Cells(1, 9).Value, 2) 
        writeToRow = writeToRow + 1 
        Application.DisplayAlerts = False 
        Worksheets(1).Delete 
        Application.DisplayAlerts = True 
    Next 
    Worksheets(1).Columns("A:B").AutoFit 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I would gladly do this all on my own but I feel that my knowledge is limited for this task. I really hope you will be able to help me!

Dima

I have attached the each of the macros in its corresponding workbook and also a few text files for importing.

Hello friends,

I have the below code :


	VB:
	
 Range) 
    Application.EnableEvents = False 
     
    finalrow = Cells(65536, 2).End(xlUp).Row 
    For i = 5 To finalrow 
        If Cells(i, 2).Value = "1" Then 
            Range("C3:J3").copy 
            Cells(i, 3).Select 
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
            SkipBlanks:=False, Transpose:=False 
        End If 
    Next i 
     
    Application.EnableEvents = True 
    Application.CutCopyMode = False 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
It baiscally copies row C3:J3 and pastes it in the row range "C:J" depending on where "1" is placed in column B. Code works fine, I want to add another loop in the code which deletes the entire row if the cells in column "B" do not equal "1".

Thank you in advance!
Nawaf

I need a VBA code that requires:

1. Cell b15, in worksheet Sheet1 (no other sheet) to contain some type of content.

2. If not a message box appears telling the user to enter something into the cell.

3. It exits the sub and selects cell b15.

Thank you.


No luck finding an answer? You could always try Google.