I want to copy a range of table and paste it in a new workbook. I want to copy ranges composed of other columns and rows but as variable. For example, I copy columns C and E with the rows from 1 to 17, 20, from 32 to 39 and 45. And I want to proceed that maximum 10 times (for the columns) and if I finish selecting the columns to copy, I exit. To be more clear, there is an example: I select column B, D, F and than select the rows to be copied (they are the same for all the columns) and finally copy them and paste them in a new workbook. So I stopped after three times and copy what I selected and go out.
My Code:
Sub Macro33()
Dim col As String, row As String
'Dim row As Integer
Dim CopyRange As Range
Set CopyRange = [A:A]
For i = 1 To 10
col = InputBox("Column number " & i & ", if finish write 'done'")
If col = "done" Then
MsgBox ("copy finished")
GoTo ExitIteration
Else
row = InputBox("row number to copy (max to 62), if finish write 'done'")
Do While row <> "done"
Set CopyRange = Union(CopyRange, Range(col & row & ":" & col & row))
row = InputBox("row number to copy (max to 62), if finish write 'done'")
Loop
End If
Next
ExitIteration:
CopyRange.copy
Workbooks.Add
ActiveSheet.Paste
Windows("Pedro.xlsm").Activate
End Sub
The problem is in the Line:
Set CopyRange = Union(CopyRange, Range(col & row & ":" & col & row))
I always get application-defined or object-defined error (error 1004) and can't find any solution for it!!
Any help please?
Union can only join two or more ranges. On your first pass CopyRange will be nothing so the union method will fail.
Try something like:
If copyrange Is Nothing Then
Set copyrange = Range(col & Row & ":" & col & Row)
Else
Set copyrange = Union(copyrange, Range(col & Row & ":" & col & Row))
End If
Related
I have written a code which gives me exact count of empty/blank cells in a column/s.
This shows the results if I run the code for column A
Sub countblank()
Const column_to_test = 2 'column (B)
Dim r As Range
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count,
column_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column B")
Const columns_to_test = 3 'column (C)
Set r = Range(Cells(3, columns_to_test), Cells(Rows.Count,
columns_to_test).End(xlUp))
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows
with blank cells in column c ")
'and so on i can count the blanks for as many columns i want
End Sub
But the problems are as follows:-
If there are no blanks, this macro will throw an error and will terminate itself. What if I want to run the remaining code?
Using array or something equivalent I want to search the multiple columns by header at the same time, instead of column number that to separately as shown in the code.
If a blank/s is found it pops a Msgbox but can we get the list of error in a separate new sheet called "error_sheet"?
Function getBlanksInListCount(ws As Worksheet, Optional FirstRow = 2, Optional TestColumn = 2)
With ws
getBlanksInListCount = WorksheetFunction.countblank(.Range(.Cells(FirstRow, TestColumn), .Cells(.Rows.Count, TestColumn).End(xlUp)))
End With
End Function
Try this
Sub countblank()
Dim i As Long
For i = 2 To 10 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
Sheets("error_sheet").Range(r.Address).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
Next i
End Sub
Try sub MAIN to examine the first three columns:
Sub countblank(column_to_test As Long)
Dim r As Range, rr As Range, col As String
col = Split(Cells(1, column_to_test).Address, "$")(1)
Set r = Range(Cells(2, column_to_test), Cells(Rows.Count, column_to_test).End(xlUp))
On Error Resume Next
Set rr = r.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rr Is Nothing Then
MsgBox ("There are no Rows with blank cells in column " & col)
Else
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & " Rows with blank cells in column " & col)
End If
End Sub
Sub MAIN()
Dim i As Long
For i = 1 To 3
Call countblank(i)
Next i
End Sub
Q1 can be answered by using an error handling statement. Error handling statements can be as simple or complicated as one would like them to be. The one below is probably my first go to method.
' if no blank cells found, code continues
On Error Resume Next
MsgBox ("There are " & r.SpecialCells(xlCellTypeBlanks).Count & _
" Rows with blank cells in column B")
Using headers would work fine. Please see final answer below for this method.
This answer is a minor change from the answer submitted by Imran Malek
Sub countblank()
Dim i As Long
' new integer "row" declared
Dim row As Integer
' new integer "row" set
row = 1
For i = 2 To 4 ' for looping through the columns
Dim r As Range
Set r = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
'for not getting error and adding error messages in the error_sheet
'MsgBox ("There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column)
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub
Final answer: My apologies for the lengthy answer. This answer is a modification of Imran Malek's answer, found in the link of answer 3. Please note, this version does not contain error handling, explained in Q1.
Sub countblank()
Dim Header(1 To 4) As String
Header(1) = "Name"
Header(2) = "Age"
Header(3) = "Salary"
Header(4) = "Test"
Dim i As Integer
Dim row As Integer
Dim r As Range
Dim c As Integer
row = 1
' **NOTE** if you add any more values to {Header}, the loop has to be equal to the Header count
' i.e. 4 {Headers}, 4 in the loop
For i = 1 To 4
'looking for the header in row 1
c = Cells(1, 1).EntireRow.Find(What:=Header(i), LookIn:=xlValues).Column
'defining the column after header is found
Set r = Range(Cells(2, c), Cells(Rows.Count, c).End(xlUp))
' using the value in row to insert our output
Sheets("error_sheet").Range("A" & row).Value = "There are " & Application.WorksheetFunction.countblank(r) & " Rows with blank cells in column" & r.Column
' adding 1 to "row" to prep for next output
row = row + 1
Next i
End Sub
I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with
I have two sheets in an excel file namely bank_form and Pay_slip.
I am trying to write a vba to check whether value/text in cell B5 of sheet Pay_slip is equal to value/text in cell B8 of sheet Bank_form. Similary it will check all values till the last row of sheet Pay_slip.
But my code is not working it always comes true i.e. it always flash the message "All employees found."
Please find my mistake(s).
Sub CommandButton1_Click()
Dim LastRow As Long
LastRow = Worksheets("Bank_form").Range("B" & Rows.Count).End(xlUp).Row
LR = Worksheets("Pay_slip").Range("B" & Rows.Count).End(xlUp).Row
If Worksheets("Pay_slip").Range("B5" & LR).Value = Worksheets("Bank_form").Range("B8" & LastRow) Then
MsgBox "All Employees Found."
Worksheets("Bank_form").Range("F" & LastRow + 1).Formula = "=SUM(F8:F" & LastRow & ")"
Else: MsgBox "Employee(s) missing Please check again!"
End If
End Sub
you will need a loop something like this
Dim i as Long
For i = 5 to LastRow 'start at B5
If Worksheets("Pay_slip").Range("B" & i).Value = Worksheets("Bank_form").Range("B" & i + 3) Then
' ... your other stuff here
next i
If Worksheets("Pay_slip").Range("B5").Value = Worksheets("Bank_form").Range("B8").Value Then MsgBox "The values are the same"
I have no idea why you involved the number of rows in your code but they are useless in order to check the equivalence in the values in a specific cell only
I would like to count all the blank and non-blank cells in a given range of data only until the cell with a data. But I also have a limited to refer on only, its from O4:O18.
Given from the sample above, I only have to count blank cells from Row4 to the cell with data which is asd. Any help? Thanks!
The use of count is to count the blank cells within the non-blank cells. lets say that the last row with data is 15, so 15 will be the last row with data and from row 4 to row 15, will count the blank cells in the Range.
you can easely achieve desired result using worksheetfunction, try this:
Sub test()
Dim iBlank&, iNonBlank&, rng As Range
Set rng = Range("O4:O" & [O4:O18].Find("*", , , , , xlPrevious).Row)
With WorksheetFunction
iNonBlank = .CountA(rng)
iBlank = .CountBlank(rng)
End With
MsgBox "Blank: " & iBlank & vbNewLine & "NonBlank: " & iNonBlank
End Sub
I am not 100% sure about what is your goal. I understand that you have a maximum range from "O4" to "O18" (it can be smaller) and you want to go from "O4" to the last non blank cell in that range, count the number of blank and non-blank cells. If it is indeed what you want to do, try the code below (explanations are in it):
Sub CountingBlankAndNonBlank()
Dim MyRange As Range
Dim LastRow As Long, TotalRange As Long
Dim CountBlank As Long, CountNonBlank As Long
'Find the last row with data in the Range("O4:O18")
LastRow = 19 - Range(Cells(18, 15), Cells(Rows.Count, 15).End(xlUp)).Count
'Set a range from "O4" to last cell with data
Set MyRange = Range(Cells(4, 15), Cells(LastRow, 15))
'How many cells in my Range
TotalRange = LastRow - 3
'How many blank cells in my Range
CountBlank = MyRange.SpecialCells(xlCellTypeBlanks).Count
'How many non-blank cells in may range (Total - Blank)
CountNonBlank = TotalRange - CountBlank
MsgBox "There are:" & vbNewLine _
& " - " & CountBlank & " blank cells" & vbNewLine _
& " - " & CountNonBlank & " non-blank cells" & vbNewLine _
& " - " & LastRow & " would be the lastrow"
End Sub
Count blank cells (returns 3 in your 2nd example and #N/A if all cells blank):
=COUNTBLANK($O$4:INDEX($O$4:$O$18,LOOKUP(2,1/($O$4:$O$18<>""),ROW($O$4:$O$18))-3))
Count non-blank cells (returns 6 in your 2nd example and 1 if all cells blank):
=COUNTA($O$4:INDEX($O$4:$O$18,LOOKUP(2,1/($O$4:$O$18<>""),ROW($O$4:$O$18))-3))
Using the Lookup formula from here: What is this programmer doing with his Lookup function?
I am a newbie of VBA, so sorry for the basic question. I need to create a loop where at each iteration the script:
copies O6:AA6 of Wb1 into O1:AA1 of the same Workbook
copies the columns B:E into Wb2, in the sheet named as the value contained in N6 of Wb1, say "DGP1".
repeats the two above steps: copy O7:AA7 into O1:AA1, copy B:E into Wb2 (sheet name given by the value contained in N7 of Wb1, say "DGP2").
The code I have written, although does not implement a loop nor refers to the values in N6, N7, at least performs the computations I need. After having defined the two Workbooks it consists of:
Wb1.Activate
Range("O6:AA6").copy
Range("O1:AA1").PasteSpecial
Columns("B:E").copy
Wb2.Activate
Sheets("DGP1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Wb1.Activate
Range("O7:AA7").copy
Range("O1:AA1").PasteSpecial
Columns("B:E").copy
Wb2.Activate
Sheets("DGP2").Select
Selection.PasteSpecial Paste:=xlPasteValues
In reality I have many more rows to copy-paste, and I need to refer to the final sheet names through the entries present in N6, N7, ....
thanks for any suggestion,
Stefano
It's a good start; here are some tips for writing macros that will help you get going, but also improve your code
Ranges - Most of the time, it's faster and more efficient to set your
"Destination" range equal to your "origin" range, if the ranges are
the same. So, instead of doing
Range("O6:AA6").copy
Range("O1:AA1").PasteSpecial
you can do...
Range("O1:AA1") = Range("O6:AA6").Value
Select - You almost never need to "Select" cells and sheets (unless you want
that cell/sheet to be selected when your macro has finished running).
It's better to instead refer to the sheet directly. Again, instead
of
Wb1.Activate
Range("O6:AA6").copy
Range("O1:AA1").PasteSpecial
Columns("B:E").copy
Wb2.Activate
Sheets("DGP1").Select
Selection.PasteSpecial Paste:=xlPasteValues
assuming your data is on sheet 1 of Wb1, you can do...
Wb1.Sheets("Sheet1").Range("O1:AA1") = Wb1.Range("O6:AA6").Value
Wb2.Sheets("DGP1").Columns("B:E") = Wb1.Sheets("Sheet1").Columns("B:E").Value
For Loop - To use a for loop, you can set a variable and build your range
string given an incrementing variable. For example, you can set the
variable x to equal 6 and increment how ever many times you want
(let's say 5 times to 10)
for x = 6 to 10
Wb1.Sheets("Sheet1").Range("O1:AA1") = _
Wb1.Range("O" & x & ":AA" & x).Value
Wb2.Sheets("DGP1").Columns("B:E") = _
Wb1.Sheets("Sheet1").Columns("B:E").Value
next x
Range / Sheet References - If the values in your cells are names of valid Ranges and / or sheets, they can easily be used to build a
reference to that Range / Sheet. For example,
Wb1.Sheets("Sheet1").Range("N6").Value is equal to "DPG1", the
value in N6 on your Sheet1 of Wb1. Combining that with the
loop, Your final code would then look like the following
for x = 6 to 10
Wb1.Sheets("Sheet1").Range("O1:AA1") = _
Wb1.Range("O" & x & ":AA" & x).Value
Wb2.Sheets(Wb1.Sheets("Sheet1").Range("N" & x).Value).Columns("B:E") = _
Wb1.Sheets("Sheet1").Columns("B:E").Value
next x
Now that that's done, you should know that you're going to be pasting the different values O6, O7, etc, into the same location every time (O1). I'm assuming this is not what you want, but you now have some of the tools to update that part as well.
Hope this helps...
Try this (you need to rename the Workbook names and Worksheet names):
Sub SO_19646599()
Dim oWB1 As Workbook, oWB2 As Workbook
Dim oWS1 As Worksheet, oWS2 As Worksheet
Dim oRngRef As Range, oRng1 As Range, oRng2 As Range
Dim sTmp As String, iOffset As Long, iErr As Long, sErr As String
' Source Workbook and Worksheet (assumed already open)
Set oWB1 = Workbooks("Wb1")
Set oWS1 = oWB1.Worksheets("Sheet1") ' Assuming Sheet1
' Target Workbook (assumed already open)
Set oWB2 = Workbooks("Wb2")
' Reference range to start
Set oRngRef = oWS1.Range("N6")
' Offset counter
iOffset = 0
' Loop until oRngRef is an empty cell
Do Until IsEmpty(oRngRef)
' Copy O6:AA6 to O1:AA1 in Wb1 (assuming Sheet1), with row offset
Set oRng1 = oWS1.Range("O6:AA6").Offset(iOffset, 0)
Set oRng2 = oWS1.Range("O1:AA1").Offset(iOffset, 0)
oRng1.Copy Destination:=oRng2
' Get reference to Worksheet in Wb2 by the value contained in N6 of Wb1 (assumed Sheet1), with row offset
sTmp = oRngRef.Value
Set oWS2 = oWB2.Worksheets(sTmp)
If oWS2 Is Nothing Then
iErr = iErr + 1
sErr = sErr & iErr & vbTab & "No such """ & sTmp & """ worksheet (" & oRngRef.Address & ") in " & oWB2.Name & vbCrLf
Else
' copies the columns B:E from Wb1 (Sheet1) to Wb2 (Sheet name as N6)
oWS1.Columns("B:E").Copy Destination:=oWS2.Columns("B:E")
End If
iOffset = iOffset + 1
' Update Reference range
Set oRngRef = oWS1.Range("N6").Offset(iOffset, 0)
Loop
If iErr > 0 Then
Debug.Print sErr
MsgBox iErr & " errors occurred, please review Immediate window." & vbCrLf & vbCrLf & sErr
End If
' Cleanup
Set oWS2 = Nothing
Set oWB2 = Nothing
Set oWS1 = Nothing
Set oWB1 = Nothing
End Sub