excel VB copy cells from on sheet to another - excel
I´m having problems with my code
I want this code to copy cells from one sheet to another but with the following trick
(english is not my first language, Sorry )
In "sheet1" there is "date and ticket number" always in the same cell, but I also want to copy a list of values that can change in amount...(A10)
all these values go to "sheet2" in the same row...
"date1" "ticket123" "itemA" "amount"
"date1" "ticket123" "itemB" "amount2"
Private Sub CommandButton1_Click()
filalibre = Sheets("sheet2").Range("a1048576").End(xlUp).Row + 1
ActiveSheet.Range("a10").Select
fila = 10
While ActiveCell.Value <> ""
Sheets("sheet2").Cells(filalibre, 1) = ActiveSheet.Range("E4")
Sheets("sheet2").Cells(filalibre, 2) = ActiveSheet.Range("E2")
Sheets("sheet2").Cells(filalibre, 3) = ActiveSheet.Offset(0, 0)
Sheets("sheet2").Cells(filalibre, 4) = ActiveSheet.Offset(0, 1)
filalibre = filalibre + 1
ActiveCell.Offset(1, 0).Select
Wend
Call limpieza
End Sub
What can I read to fix this... or can anyone help me
Since you have not mentioned the exact problem or the error you see, I can see some possible sources of an issue.
Replace
Sheets("sheet2").Cells(filalibre, 3) = ActiveSheet.Offset(0, 0)
Sheets("sheet2").Cells(filalibre, 4) = ActiveSheet.Offset(0, 1)
By
Sheets("sheet2").Cells(filalibre, 3) = ActiveCell.Offset(0, 0)
Sheets("sheet2").Cells(filalibre, 4) = ActiveCell.Offset(0, 1)
Besides this,there are a few other improvements that can be done to your code. But first try to get it working without an error.
Related
INDEX and AGGREGATE Function in Excel VBA
I'm trying to move an in cell formula to VBA, because otherwise it's always recalculating, even when I deactivate the excel option, it comes back when I reopen the file. That's why I want to move that formula to VBA, where it happens only when I press a button, which is much smarter. I have a master table with data, which I aggregate and index and express it on another sheet in a table. -> column A to S are in the master table, in the aggregated table, I will only have column A,C,E,G,H,I,J,K,L,M and P The formula I want to move to VBA is the following: =IFERROR(INDEX(Endkontrolle!$A:$S;AGGREGATE(15;6;ROW(Endkontrolle!$A:$S)/((FIND($B$3;Endkontrolle!$F:$F;1)>0)*(Endkontrolle!$S:$S="x"));ROW()-32)-0;1);"") Can somebody help me translate that formula to VBA script? thank you very much
Try this code:
Sub Button1_Click2()
'Declarations.
Dim RngTable As Range
Dim RngTarget As Range
Dim StrColumnsIndex As String
'A string is used to stores the index of the columns to be copied.
StrColumnsIndex = "1;3;5;7;8;9;10;11;14;15;16"
'RngTable is set as the range that will host the aggregated table.
Set RngTable = Sheets("Aggregated sheet").Range("A33:K34") '< EDIT THIS LINE ACCORDGLY TO YOU NEED
'Clearing RngTable.
RngTable.ClearContents
'Checking if StrColumnsIndex and RngTable are compatible.
If UBound(Split(StrColumnsIndex, ";")) + 1 <> RngTable.Columns.Count Then
MsgBox "The number of columns requested via StrColumnsIndex and the number of columns avaiable in RngTable do not match. Redefine the variables properly. The aggregated table will not be updated.", vbCritical + vbOKOnly, "Variable mismatch"
Exit Sub
End If
'Covering each cell in RngTable.
For Each RngTarget In RngTable
'The result is reported in each cell. The [row] element of the INDEX is obtained by subtracting _
RngTable.Row from the RngTarget.Row and adding one. This way each row is properly reported. The _
[col] element of the INDEX is obrained by splitting StrColumnsIndex using the difference between _
the RngTarget.Column and RngTable.Column as index. This way each requested column as listed in _
StrColumnsIndex is reported.
'RngTarget.Formula = "=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x""))," & RngTarget.Row - RngTable.Row + 1 & ")-0," & Split(StrColumnsIndex, ";")(RngTarget.Column - RngTable.Column) * 1 & "),"""")"
RngTarget.Value = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x""))," & RngTarget.Row - RngTable.Row + 1 & ")-0," & Split(StrColumnsIndex, ";")(RngTarget.Column - RngTable.Column) * 1 & "),"""")")
'If RngTarget contains nothing then it's assumed there are no more results to be reported and the macro is terminated.
If RngTarget.Value = "" Then Exit Sub
Next
End Sub
Thanks for that. I implemented it and it works for 1 row. If I want to add the next data set from the main table, that does only repeat the content from previous row. How can I achieve, that it lists me more than 1 line of aggregated data?
Expected result:
it picks the relevant rows of data and lists it (different data according the find criteria)
Actual result:
it picks only 1 row and repeats it for the second line
Now I defined following code:
Sub Button1_Click()
Cells(33, 1) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,1),"""")")
Cells(33, 2) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,3),"""")")
Cells(33, 3) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,5),"""")")
Cells(33, 4) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,7),"""")")
Cells(33, 5) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,8),"""")")
Cells(33, 6) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,9),"""")")
Cells(33, 7) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,10),"""")")
Cells(33, 8) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,11),"""")")
Cells(33, 9) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,14),"""")")
Cells(33, 10) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,15),"""")")
Cells(33, 11) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,16),"""")")
Cells(34, 1) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,1),"""")")
Cells(34, 2) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,3),"""")")
Cells(34, 3) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,5),"""")")
Cells(34, 4) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,7),"""")")
Cells(34, 5) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,8),"""")")
Cells(34, 6) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,9),"""")")
Cells(34, 7) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,10),"""")")
Cells(34, 8) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,11),"""")")
Cells(34, 9) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,14),"""")")
Cells(34, 10) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,15),"""")")
Cells(34, 11) = Evaluate("=IFERROR(INDEX(Endkontrolle!A:S,AGGREGATE(15,6,ROW(Endkontrolle!A:S)/((FIND(B3,Endkontrolle!F:F,1)>0)*(Endkontrolle!S:S=""x"")),ROW()-32)-0,16),"""")")
End Sub
Here's a sample of the data in the main table "Endkontrolle":
Date
Product
Employee
...
Date Range
22.04.2022
MOTI
AKAH
...
x
23.04.2022
MOTI_BG
AKAH
...
x
26.04.2022
MOTI
AKAH
...
On the reporting page, I would like to list down up to 20 rows of Data, which are in the Date Range ('x') from the "Endkontrolle" worksheet.
In the upper example, it should list row 1+2, but not 3.
Format and spacing check using VBA Macro
Actually I want to check spacing and format of my Values Using VBA Macro. It is a dynamic string say 1 Count (Pack of 1) or 2 Count (Pack of 1), 20 g (Pack of 1) or 50 g (Pack of 2), 100 ml (Pack of 2) or 200 ml (Pack of 1). so the format remains the same but the integer alone changes in each cell. Also I wrote a code using instr function but it is not able to validate and give me the output. I want integer to be be defined as X and format should be the same.
I have mentioned the code below which I tried. I need some concept which can be helpful. I have attached the screenshot which needs to be validated. Thanks a lot.
Sub QualityCheck()
Dim LastColumn As Long
Dim X(1 To 20000) As Integer
ActiveSheet.Select
Range("A1").Select
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Columns.Select
ActiveCell.Value = "Quality Error"
Range("A1").Select
Set P = Range("A$1:AD$1")
For Each cell In P
If cell.Value = "ASIN" Then cell.Offset(1, 0).Select
Next
Do While ActiveCell.Value <> ""
If ActiveCell.Offset(0, -2).Value = "DE" Then
If ActiveCell.Offset(0, 12).Value Like " Stück ( er Pack)" Then
ActiveCell.Offset(0, 26).Value = " Correct"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Also I have tried like declaring a varaible like X = 1 to 1000 and concat "X&" Stuck ("&X&"er Pack")" but still it didne work. It would be helpful if I get the syntax to crack the concept. Thanks in advance.
From what I understood you need to modify this line:
If ActiveCell.Offset(0, 12).Value Like "*Stück (*er Pack)" Then
This modification goes like this:
Any char - then followed by "Stück (" then ANY CHARS - followed by "er Pack)"
Should work, let me know if it did!
Hope it helps.
Inserting Blank Rows in Excel VBA
Hey I have been writing some code to add a part ID to a spreadsheet off of a user form in Excel VBA. I have been reading through different documentation and can not figure out why no matter what type of method of inserting a row I try it inserts a row with a repeating value instead of a blank one. If anyone knows how to specify blank, other than writing the whole row to blank and then writing my numbers I want after, that would be appreciated. I have tried both the following lines to add a row Cells (x+1 ,column).EntireRow.Insert Shift:= xlDown ws1.Rows(x+1).Insert Shift:=xlDown This is the function it is used in: Public Sub Add(IDRange As Range) SearchCell = Cells(x, IDRange.Column) Cells(x, IDRange.Column).Select Do If SearchCell = PartID Then MsgBox " this Company Already uses this part" Exit Sub ElseIf x <> StopRow Then x = x + 1 SearchCell = Cells(x, IDRange.Column) End If Loop While x <> StopRow And SearchCell <> PartID Cells(x + 1, IDRange.Column).EntireRow.Insert Shift:=xlDown Cells(x, IDRange.Column).Value = PartID MsgBox PartID & " has been added to Adress " & Cells(x, IDRange.Column).Address Cells(x, IDRange.Column).Select End Sub Bellow is the function that calls the Add Function and where I belive it may be getting the company name from Private Sub AddPart_Click() AddPartCounter = 0 Company = UserForm1.CompanyBox.Value PartID = UserForm1.PartBox.Value If Company = "" Then MsgBox " Please put in the company you would like the part to go under" ElseIf PartID = "" Then MsgBox " Please put in the Part you would like entered" ElseIf UserForm1.Studs.Value = False And UserForm1.Spreaders.Value = False And UserForm1.Blocks.Value = False And UserForm1.Imma.Value = False Then MsgBox "Please select the type of part you are trying to add" Else Dim CurrentCell Set CurrentCell = Cells.Find(What:=Company, LookAt:=xlWhole) If CurrentCell Is Nothing Then MsgBox " Company Not Found " Exit Sub End If x = CurrentCell.Row Do Set CurrentCell = CurrentCell.Offset(1, 0) Loop While CurrentCell.Offset(1, 0) = "" And Not CurrentCell Is Nothing And CurrentCell.Offset(1, 0).Row <> thisvar.Row + 1 StopRow = CurrentCell.Row 'If they are trying to add a nut If UserForm1.Imma.Value = True Then Call Add(Nut_ID_Rng) 'IF they are trying to add a stud ElseIf UserForm1.Studs.Value = True Then Call Add(Stud_ID_Rng) 'If they are trying to add a block ElseIf UserForm1.Blocks.Value = True Then Call Add(Block_ID_Rng) 'If they are trying to add a spreader ElseIf UserForm1.Spreaders.Value = True Then Call Add(Spreader_ID_Rng) End If End If AddPartCounter = 1 End Sub I know that the repeating pattern is coming from the insert line through debugging but I can not figure out why I have tried changing variables to numbers and it still did the same thing. This what it looks like with the repeating values. enter image description here
The problem is that you most likely have a value still stored in your clipboard when you execute the Macro. To fix that, simply add this line of dode before running the insert line: Applcation.CutCopyMode = False That will clear your clipboard and allow the inserted rows to be blank.
Excel VBA Selection.Copy is pasting empty values in destination workbook sheet
I have written an Excel VBA to copy data from selected cells from one workbook sheet to another. Here it is working fine upto certain cells, after pasting some values, after sometime VBA is pasting empty values. I mean eventhough the source cell is not empty, it is pasting empty values. I have put breakpoint and saw, but the value was there. Please help me to solve this issue.
The code is as follows.
Set objClickScriptWB = objExcelWB.Workbooks.Open(SourceWBPath)
For intSheet = 9 To 12 'objClickScriptWB.Worksheets.Count
If InStr(1, objClickScriptWB.Worksheets(intSheet).Name, "SC", vbTextCompare) > 0 Then
blnScriptSheet = 1
objClickScriptWB.Worksheets(intSheet).Activate
For r = 24 To objClickScriptWB.Worksheets(intSheet).UsedRange.Rows.Count
If Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Trim(LCase("Transaction")) And Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Empty And objClickScriptWB.Worksheets(intSheet).Cells(r, 6).MergeArea.Cells.Count = 1 Then
objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Select
If blnCompSht = 0 Then
Set objComparisonSheet = ThisWorkbook.Worksheets.Add
objComparisonSheet.Name = "Comparison"
objComparisonSheet.Activate
objComparisonSheet.Cells(2, 2).Value = "Clickscript Transaction names"
i = 3
objExcelWB.Selection.Copy
objComparisonSheet.Activate
objComparisonSheet.Cells(i, 2).Select
'Sheet3.Range("B2").Select
'objComparisonSheet.Range("B" & i).PasteSpecial Paste:=xlPasteValues
objComparisonSheet.Paste
'Sheet2.Range("G2").Cells
i = i + 1
blnCompSht = 1
'Application.Wait (Now + TimeValue("00:00:01"))
ElseIf blnCompSht = 1 Then
ThisWorkbook.Worksheets("Comparison").Activate
Dim LastRow As Integer
For intRow = 2 To ThisWorkbook.Worksheets("Comparison").Rows.Count
If ThisWorkbook.Worksheets("Comparison").Cells(intRow, 2).Value = Empty Then
i = intRow
Exit For
End If
Next
objExcelWB.Selection.Copy
ThisWorkbook.Worksheets("Comparison").Cells(i, 2).Select
'ThisWorkbook.Worksheets("Comparison").Range("B" & intRow).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets("Comparison").Paste
i = i + 1
'Application.Wait (Now + TimeValue("00:00:01"))
End If
'End If
'Next
'Call CompareTxnNames(objClickScriptWB.Worksheets(intSheet).Name)
End If
'Next
Next
End If
Next
End Sub
Please help me
Thanks
You could also directly apply the value of one cell to the other cell with a code like this: CellTarget.Value2 = CellSource.Value2 Or in your case: objComparisonSheet.Cells(i, 2).Value2 = objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value2 Side note: Get into the habit of using Value2 for that is the true value of the cell compared to Value which is the value with formatting applied to it. The latter is slower and in case of date values can give wrong days and months when you arent using the US dateformat in your excel.
VBA Script for Formatting Phone Numbers
I am trying to write a VBA Script to format a list of several thousdand phone numbers I have stored in an excel spread sheet. So far I have this, but when I run it it doesn't format the phone number. It does add the value NULL if the cell is empty but doesnt format the number anyone see what I am doing wrong?
Sub CheckPhoneNumber()
Dim retNumber As String
Range("K3").Activate
Do Until ActiveCell.Row = 3746
If ActiveCell.Value = "" Then
ActiveCell.Value = "NULL"
Else
For i = 1 To Len(ActiveCell.Value)
If Asc(Mid(ActiveCell.Value, i, 1)) >= Asc("0") And Asc(Mid(ActiveCell.Value, i, 1)) <= Asc("9") Then
retNumber = retNumber + Mid(ActiveCell.Value, i, 1)
End If
Next
If Len(retNumber) > 10 Then
cleanPhoneNumber = Format(retNumber, "(+#) 000-000-0000")
Else
cleanPhoneNumber = Format(retNumber, "000-000-0000")
End If
End If
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Looks like you forgot to write cleanPhoneNumber back to the sheet? you need an ActiveCell.Value = cleanPhoneNumber before the final end if.