Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 5 years ago.
Improve this question
I have two workbooks. A source Workbook(1) and an Destination Workbook(2).
I am copying all the Contents from 1 to 2.
I have the below code running for this.
I have a small problem with the workbook.
I have my source book with pictures in it , Like the picture below.
I have included the column to be copied in my code. but I don't get those pictures. Could someone tell me how I can copy these pictures with the contents to my destination sheet, with the below code.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
ThisWorkbook.Sheets("2").Range("A4:P1000").ClearContents
CopyCol = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LCell = Selection.SpecialCells(xlCellTypeLastCell).Address
LCC = Selection.SpecialCells(xlCellTypeLastCell).Column
LCR = Selection.SpecialCells(xlCellTypeLastCell).Row
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Jenny\Raw data\Report.xlsx")
For Count = 0 To UBound(CopyCol)
Set temp = Range(CopyCol(Count) & "22:" & CopyCol(Count) & LCR)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("2").Range("A4").PasteSpecial
x.Close
End Sub
Could someone suggest, how I can copy those picture with the content to the destination workbook.
Instead of
y.Sheets("2").Range("A4").PasteSpecial
try
y.Sheets("2").Paste y.Sheets("2").Range("A4")
Related
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 12 months ago.
Improve this question
I have 500 value in column A and 200 value in column B. I need to check that column A values are present in column B. if value is found then need to highlight that founded value.
This is my attempt. Your questions is pretty vague though, so there are a few assumptions. Good luck!
Sub compareColumns()
' im assuming the sheet in question is the index 1 sheet in the workbook
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
' im assuming no header
Dim lastRowA As Integer: lastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim lastRowB As Integer: lastRowB = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
Dim i As Integer, j As Integer
Dim matchMe As String
For i = 1 To lastRowA
matchMe = ws.Cells(i, 1).Value
For j = 1 To lastRowB
If ws.Cells(j, 2).Value = matchMe Then
ws.Cells(i, 1).Interior.Color = vbRed
Exit For
End If
Next j
Next i
End Sub
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I am trying to create a code that looks at column A in sheet1, then insert new lines in sheet2. Then paste the contents of column A (sheet1) into column A on sheet2. See attached pictures:
Sheet1 - total list
Sheet2 - existing list, need to add new lines from sheet1 and shift down the rest of contents.
Sheet3 - Result.
I do this manually every time but I am trying to make it automatic so I can save some time. I will assign a button to this.
Thanks in advance.
Nelson
enter image description here
enter image description here
enter image description here
try the code below :
Sub test()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = ThisWorkbook.Sheets("sheet1")
Set ws2 = ThisWorkbook.Sheets("sheet2")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
i = 1
Do While ws.Cells(i, 1).Value = ws2.Cells(i, 1).Value
i = i + 1
Loop
For j = i To lastRow
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
ws2.Rows(lastRow2 + 1).EntireRow.Insert
ws2.Range("A" & lastRow2 + 1).Value = ws.Range("A" & j).Value
Next j
End Sub
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 years ago.
Improve this question
Columns A and G are OrderID, each with their own AMOUNT, Columns C and H.
If the OrderID columns match, I need to compare Columns C and H**.
If they are different, then highlight the cell. I want to use VBA for this as it's part of a larger Macro I want to add to.
You can try using below code, it will loop through all lines and compare column A with column G:G if its equal then compare C & H and if is not equal then change the colour index.
Code:
Dim Wb As Workbook, ws As Worksheet, lrow As Long, j As Long, m As Long, lrow2 As Long, Search As Variant, Search2 As Variant
Set Wb = ThisWorkbook
Set ws = Wb.Sheets("Sheet1")
lrow = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
lrow2 = ws.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
For j = 3 To lrow
Search = (ws.Cells(j, 1).Value)
Search2 = (ws.Cells(j, 3).Value)
For m = 3 To lrow2
If ws.Cells(m, 7) = Search And ws.Cells(m, 8) <> Search2 Then
ws.Range("C" & j).Interior.ColorIndex = 3
ws.Range("H" & m).Interior.ColorIndex = 3
End If
Next
Next
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 6 years ago.
Improve this question
I'm writing a makro formatting all non-numeric cells to text before loading to database. I have a line that I have no idea what's wrong with. My VBA skills are poor. I get run-time error '424'.
Sub formatAllCellsAsText()
Dim wsTemp As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
For sht = 3 To Worksheets.Count
Set wsTemp = Sheets(sht)
Set StartCell = Range("A4")
LastRow = wsTemp.Range("A1").CurrentRegion.Rows.Count
LastColumn = wsTemp.Range("A1").CurrentRegion.Columns.Count
For Each Cell In wsTemp.Range(StartCell, wsTemp.Cells(LastRow, LastColumn)).Cells
If Not IsEmpty(Cell.Value) And IsNumeric(Cell.Value) And InStr(wsTemp.Cells(1, Cell.Column), "Client ID") <= 0 Then
Dim Temp As Double
Temp = Cell.Value
Cell.ClearContents
Cell.NumberFormat = "#"
Cell.Value = CStr(Temp)
End If
Next
Next sht
End Sub
Set StartCell = Range("A4")
should be
Set StartCell = wsTemp.Range("A4")
Just want to summarize as I probably found the issue.
In my first code posted I did not set Cell variable that I was later referring to. I thought that Cell would be self-explanatory for VBA.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 8 years ago.
Improve this question
I am trying to split my ORASQL query into multiple workbooks with a specified number of entries for each book. I am using office 2010 if that matters. I think I should use what is below (from a previous example on row count) to get the count and so I could then use that to split the sheet.
With ThisWorkbook.Sheets("Sheet1")
recct = .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Rows.Count
End With
Im not sure where to go from here because I am not that experienced in VBA yet and
I think there might be a better way with RecordCount or something like that.
To add specifics and clairify:
I run a sql query within VBA.
It returns a list of ~176k rows with 9 different columns (A-I) into one sheet of one workbook.
I would like to copy the information from the 176k rows, 30k at a time, to separate workbooks, and save them to a specific path.
Here is the whole thing, minus my orcale connection information
Sub pull_paper_claims()
Dim ym As Variant
Dim sql As String
Dim recct As Long
ym = Range("B2").Value
Set oConOracle = CreateObject("ADODB.Connection")
Set oRsOracle = CreateObject("ADODB.Recordset")
sql = "select unique payor_name, payor_addr1, payor_city, payor_zip, payor_state, taxid, pat_account, act_id, payor_id from lisa.cc_data_" & ym & " where claim_status='p' and payor_id!='cpapr'and payor_id!='hpapr' and payor_id!='xpapr'"
'oracle connection
oConOracle.Open "my conection information"
Set oRsOracle = oConOracle.Execute(sql)
'clear it up first
Range("A3", "K200000").ClearContents
Range("A3").CopyFromRecordset oRsOracle
With ThisWorkbook.Sheets("Sheet1")
recct = .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Rows.Count
End With
Range("A1").Value = recct
'close the statement
oConOracle.Close
Set oRsOracle = Nothing
Set oConOracle = Nothing
'ActiveWorkbook.SaveAs Filename:="D:\important\job_stats_" & Format(end_date, "yyyymmdd") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End Sub
Added to Answer your question.
I literally copied what you had into a new sub and changed very little.
Sub Create_new_wb()
Const numRow = 30000 'constant for number of rows in each copy
Dim lRow As Long 'variable to contain the last row information
Dim lCol As Long 'variable to contain the last column information
Dim wbk As Workbook
Dim i As Long
Dim aryData() As Variant
'find lrow and lcolumn in data sheet
lRow = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
'loop through number of times required to part all data
For i = 1 To Application.RoundUp(lRow / numRow)
'determine size of aray and put data into array
If lRow > i * numRow Then
ReDim aryData(1 To i * numRow, 1 To lCol)
aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(numRow, lCol)
Else
ReDim aryData(1 To lRow - (numRow * i))
aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(lRow - (numRow * i), lCol)
End If
'add new workbook and paste data
Set wbk = Workbooks.Add()
wbk.Sheets(1).Cells(1, 1).Resize(UBound(aryData, 1), UBound(aryData, 2)) = aryData
'save and close workbook
wbk.SaveAs Filename:="C:\temp\" & "NewBook" & i & ".xlsx"
wbk.Close
Next
End Sub
There's two ways you can do this
From the pull macro modify it so it will populate multiple workbooks and save into various locations
Write a post processing macro to copy out data and place into new workbooks
You can start with method 2 and integrate it into the pull macro later on.
Here's what method 2 would look like:
Sub Test()
Const numRow = 30000 'constant for number of rows in each copy
Dim lRow As Long 'variable to contain the last row information
Dim lCol As Long 'variable to contain the last column information
Dim wbk As Workbook
Dim i As Long
Dim aryData() As Variant
'find lrow and lcolumn in data sheet
lRow = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = ThisWorkbook.Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
'loop through number of times required to part all data
For i = 1 To Application.RoundUp(lRow / numRow)
'determine size of aray and put data into array
If lRow > i * numRow Then
ReDim aryData(1 To i * numRow, 1 To lCol)
aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(numRow, lCol)
Else
ReDim aryData(1 To lRow - (numRow * i))
aryData = ThisWorkbook.Sheets("Sheet1").Cells((numRow * (i - 1)) + 1, 1).Resize(lRow - (numRow * i), lCol)
End If
'add new workbook and paste data
Set wbk = Workbooks.Add
wbk.Name = "NewBook" & i & ".xlsx"
wbk.Sheets(1).Cells(1, 1).Resize(UBound(aryData, 1), UBound(aryData, 2)) = aryData
'save and close workbook
wbk.SaveAs Filename:="C:\temp\" & wbk.Name
wbk.Close
Next
End Sub
Let me know if this helps!