1) My vba copies and pastes columns from sheet a to sheet b (a table) .
2) My next vba code is ran ontop of this table and I get an error.
However if I copy and paste the problem header and data manually from sheet A to Sheet B my macro(2) will work.
Also I should mention this particular column causing the problem is a column with dates. But I have tried both formats, general and date, ive tried using a formula (=SheetA!BU1:) and pasted down into sheet 2, and I've tried a macro to copy and paste the one column.. nothing works!
Not sure if it is my code, table, format, etc.
Here is my copy and paste macro, the type mismatch does not occur here but in my other code that is not included.
Sub importtodatabase(from_ws, to_ws)
Dim rng As Range, trgtCell As Range
Dim src As Worksheet
Dim trgt As Worksheet
Set src = Worksheets(from_ws)
Set trgt = Worksheets(to_ws)
Dim row_num As Integer
Dim Max_row_data As Integer
Dim source_tab As String
Application.ScreenUpdating = False
Sheets(to_ws).Select
Max_row_data = get_max_row("")
If Max_row_data <> 2 Then
Max_row_data = Max_row_data + 1
End If
Sheets("Mappings").Select
max_row = get_max_row("")
With src
For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
For row_num = 2 To max_row
If from_ws = Range("BU" & row_num).value Then
If rng = Range("BV" & row_num).value Then
rng = Range("BW" & row_num).value
Exit For
End If
End If
Next row_num
Set trgtCell = trgt.Rows(1).Find(rng.value, LookIn:=xlValues, lookat:=xlWhole)
'If .Range(rng.Offset(1), .Cells(ws.Rows.Count, "A").End(xlUp).row
If Not trgtCell Is Nothing Then
.Range(rng.Offset(1), .Cells(.Rows.count, rng.Column).End(xlUp)).copy
With trgt
.Cells(Max_row_data, trgtCell.Column).PasteSpecial xlPasteValues
End With
End If
'End If
Next rng
End With
Application.ScreenUpdating = False
End Sub
Related
I am building out a workbook where every sheet is for a different stage of a software installation. I am trying to aggregate the steps that fail by copying my fail rows into a summary sheet. I finally got them to pull, but they are pulling into the new sheet on the same row # as they are located in the original sheet.
Here is what I am using now:
Option Explicit
Sub Test()
Dim Cell As Range
With Sheets(7)
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Fail" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next Cell
End With
End Sub
I need to:
Pull row that has cell containing "Fail"
Copy row into master starting at Row 4 and consecutively down without overwriting
Run across all sheets at once-
*(they are named per step of install - do i need to rename to "sheet1, sheet2, etc"????)
When macro is run clear previous results (to avoid duplicity)
Another user offered me an autofilter macro but it is failing on a 1004 at this line ".AutoFilter 4, "Fail""
Sub Filterfail()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")
Application.ScreenUpdating = False
'sh.UsedRange.Offset(1).Clear 'If required, this line will clear the Master sheet with each transfer of data.
For Each ws In Worksheets
If ws.Name <> "Master" Then
With ws.[A1].CurrentRegion
.AutoFilter 4, "Fail"
.Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
.AutoFilter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this:
The text “Completed” in this xRStr = "Completed" script indicates the specific condition that you want to copy rows based on;
C:C in this Set xRg = xWs.Range("C:C") script indicates the specific column where the condition locates.
Public Sub CopyRows()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("C:C")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = xRStr Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Here's another way - You'll have to assign your own Sheets - I used 1 & 2 not 2 & 7
Sub Test()
Dim xRow As Range, xCel As Range, dPtr As Long
Dim sSht As Worksheet, dSht As Worksheet
' Assign Source & Destination Sheets - Change to suit yourself
Set sSht = Sheets(2)
Set dSht = Sheets(1)
' Done
dPtr = Sheets(1).Rows.Count
dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
For Each xRow In sSht.UsedRange.Rows
Set xCel = xRow.Cells(1, 1) ' xCel is First Column in Used Range (May not be D)
Set xCel = xCel.Offset(0, 4 - xCel.Column) ' Ensures xCel is in Column D
If xCel.Value = "Fail" Then
dPtr = dPtr + 1
sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
End If
Next xRow
End Sub
I think one of the problems in your own code relates to this line
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
The section Rows.Count, "A" should be referring to the destination sheet(2) but isn't because of the line
With Sheets(7)
further up
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub
I am stuck writing this Excel macro and could kindly use some help. I am trying to create a dynamic macro that will compare two tables in two different sheets and will update information for a row if different or copy a new row to the new table if not there. Both tables contain the same columns of info and have a unique product code per data row. Once a button is pressed, if the product code for the row in table1 is not found on the new table then that row will copy. If the product code is found in the new table but other information in columns is different, than that other information will be updated on the new table. If the product code is found and the other information is the same then that row will not be copied. I need this for as many lines as possible in table1.
NOTE: I thought VLOOKUP may be the route to successfully code this macro...BELOW is my attempt so far to get this to work.
Sub Copy_Attempt()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Raw Data")
Set s2 = Sheets("BAS Linkage Master")
Dim i As Integer
Dim j As Integer
Dim Proj_ID As String
Dim Lookup_Range As Range
Dim Linkage_Lookup_Range As Range
Dim Raw_Percent_Complete As String
Dim Linkage_Percent_Complete As String
Set Lookup_Range = s1.Range("A1:O1000")
Set Linkage_Lookup_Range = s2.Range("A6:N1000")
For i = 2 To 1000
Proj_ID = s1.Range("F" & i).Value
Raw_Percent_Complete = Application.WorksheetFunction.VLookup(Proj_ID, Lookup_Range, 10, False)
Next
For j = 7 To 1000
Linkage_Percent_Complete = s2.Range("I" & j).Value
Next
If Raw_Percent_Complete = Linkage_Percent_Complete Then
' DO NOT COPY THAT ROW OVER
Else
Percent_Complete = Range("I" & j).Value
'UPDATE PERCENT COMPLETE FOR THAT SPECIFIC PRODUCT CODE
End If
Sheets("Raw Data").Activate
Columns("H").EntireColumn.Delete
Range("A2:P1000").Select
Selection.Copy
Sheets("BAS Linkage Master").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial
' Sheets("Welcome").Activate
' Range("A11:O11").ClearContents
Sheets("Raw Data").Activate
Range("A2:N10000").ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("BAS Linkage Master").Activate
End Sub
This is a nice little script that looks for differences and highlights the differences.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
cell.Interior.Color = vbYellow
ws2.Range(Celladdress).Interior.Color = vbYellow
End If
Next cell
End Sub
You can use the same concept to copy the values from one table to another.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
ws2.Range(Celladdress).Value = ws1.Range(Celladdress).Value
End If
Next cell
End Sub
I have tried to implement similar code from a post that contained this code.
it works great copying from specified cells but I need it to paste the cell values from the source not the cell contents(formula etc.) have tried several things but all give errors
TIA
Sub AlonsoApprovedList()
Dim cell As Range
Dim rngDest As Range
Dim i As Long
Dim arrColsToCopy
arrColsToCopy = Array(1, 3, 4, 5)
'----For every cell in row G on the ESI Project Data sheet----'
Set rngDest = Worksheets("Alonso Approved List").Range("A3")
Application.ScreenUpdating = False
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000").Cells
If cell.Value = "Card" Then
For i = LBound(arrColsToCopy) To UBound(arrColsToCopy)
With cell.EntireRow
.Cells(arrColsToCopy(i)).Copy rngDest.Offset(0, i)
End With
Next i
Set rngDest = rngDest.Offset(1, 0) 'next destination row
End If
Next cell
Application.ScreenUpdating = True
End Sub
rngDest.Offset(0, i).Value = .Cells(arrColsToCopy(i)).Value
The below code searches, copies & pastes the found data into another worksheet. However, there are blanks when this is done in the pasted worksheet. Eg: Found "To Be Copied" in Cell A1 and copied the entire row to the specified worksheet. Found "To Be Copied" in A4 and copied the entire row to the specified worksheet. However, there are two blank rows in the pasted sheet between A1 and A4. Thanks for your help.
Sub Deleting()
Application.ScreenUpdating = False
Dim wsh As Worksheet, i As Long, Endr As Long, x1 As Worksheet, p As Long
Set wsh = ActiveSheet
Worksheets.Add(Before:=Worksheets("Original Sheet")).Name = "Skipped"
Set x1 = Worksheets("Skipped")
Worksheets("ABC").Activate
i = 2
Endr = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
While i <= Endr
If Cells(i, "A") = "To Be Copied" Then
wsh.Rows(i).Copy
x1.Rows(i).PasteSpecial
p = p + 1
Endr = Endr + 1
End If
i = i + 1
Wend
End Sub
You need two counters: i for the source rows, j for the destination rows. You only increment j when a row is copied.
Your existing code needs either
A separate counter for the written row position (Cutter's point), or
Pasting to the last used row of "Skipped" using xlUp to find the last used cell
But better still would be copying the rows in a single shot using AutoFilter. Something like below
Sub Quicker()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("ABC")
Set ws2 = Worksheets.Add(Before:=Worksheets("Original Sheet"))
'in case Skipped exists
On Error Resume Next
ws2.Name = "Skipped"
On Error GoTo 0
ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "To Be Copied"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
rng1.EntireRow.Copy ws2.[a1]
End If
ws1.AutoFilterMode = False
MsgBox "Sheet " & ws2.Name & " updated"
End Sub