Hello i have this code my question is about inputbox. My inputbox is used for adressing to last folder where are my reports saved. But i want value of this inputbox (which is January 2018) also use in sub spracovanie2 to safe worbook in which is this code written. How can i make one inputbox to work for two sub precodures. I don't want to wrie same value two times. Can i make it public somehow?
Please comment if you think i don't expressing myself clearly.
Sub Spracovanie1()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim mesiac_rok As String
mesiac_rok = InputBox("Mesiac/Rok")
Set wb = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks("?????.xlsm")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B1")
ws.UsedRange.Copy Destination:=rng2
wb.SaveAs Filename:=("????????\" & mesiac_rok & "\??????.xlsx)"
wb.Close
End Sub
Sub Spracovanie2()
'
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim LastRow As Long
Set wb = Workbooks("Reporting AP Bwise source.xlsm")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Range("B4").CurrentRegion
Set ws2 = wb.Sheets("OPR Action plans_TEMP")
rng.Copy Destination:=ws2.Range("A1")
ws2.Range("A1").CurrentRegion.UnMerge
LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range("A1:AP" & LastRow).Sort Key1:=ws2.Range("N1:N" & LastRow), _
Order1:=xlAscending, Header:=xlYes
Set ws = wb.Sheets("OPEN AP")
ws.UsedRange.ClearContents
Set ws2 = wb.Sheets("CLOSED AP")
ws2.UsedRange.ClearContents
end sub
Related
I want to copy from one sheet into another. The macro should recognize the worksheet via name:
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Dim NewEnd As Long
Dim NewEnd2 As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("CALC").Select
Worksheets("CALC").Range("B5:J25000").ClearContents
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "15B2" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets("Data")
Set rngToCopy = .Range("F7, H7, N7", .Cells(.rows.Count, "F").End(xlUp))
End With
wb2.Sheets("CALC").Range("B5:D5").Resize(rngToCopy.rows.Count).Value = rngToCopy.Value
End If
This line gives me an error:
Set rngToCopy = .Range("F7, H7, N7", .Cells(.Rows.Count, "F").End(xlUp))
How can I copy mutiple columns in this case?
You can use Union to merge multiple columns to 1 Range.
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row ' get last row with data from column "F"
Set rngToCopy = Application.Union(.Range("F7:F" & LastRow), .Range("H7:H" & LastRow), .Range("N7:N" & LastRow))
rngToCopy.Copy
wb2.Sheets("CALC").Range("B5").PasteSpecial xlPasteValues
I was writing a code to select all the data entries of a Workbook which I 'Open' in a range, but the compiler gives error at the very last line (set up the Range rng)
Dim wb As Workbook
Set wb = Workbooks.Open(Range("C2") & Range("C3"))
'here Range("C2") & Range("C3") contains the location of the file's path
Dim ws As Worksheet
Set ws = wb.ActiveSheet
Dim frow As Long
frow = ws.Range("A" & Rows.count).End(xlUp).Row
Dim rng As Range
Dim frow1 As Long
frow1 = ws.Cells(1, Columns.count).End(xlToLeft).Column
Set rng = wb.ActiveSheet.Range(Cells(1, 1), Cells(frow, frow1))
Try:
Dim frow As Long
frow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
Dim rng As Range
Dim fcol As Long
fcol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(frow, fcol))
Remember that if you are using a set worksheet u have to reference it in all range objects
I am trying to write a program which would take the information from a user selected grid and the information adjacent to it and send them to another workbook. However, whenever I compile, I would get the error 1004 (Automation). Can someone please point out where I have made a mistake in my code? It will be greatly appreciated.
Sub CopyItemsByLocation()
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim strName As String
Dim i As Integer
Dim rng1 As Range
Set wbThis = ActiveWorkbook
Set wsThis = ActiveSheet
strName = ActiveSheet.Name
Set wbTarget = Workbooks.Open("C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx")
Set wsTarget = wbTarget.Worksheets(strName)
Set rng1 = Selection
For i = 1 To 4
If i = 1 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5") **'<~Error occurs here**
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 2 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("G5")
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 3 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("I5")
Set rng1 = rng1.Offset(0, 1)
Else
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("K5")
Set rng1 = rng1.Offset(0, 1)
End If
Next i
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
rng1 is already a range so
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5")
should be
rng1.Copy Destination:=wsTarget.Range("E5")
Also might want to set rng1 before opening the other workbook
Reworked a bit:
Sub CopyItemsByLocation()
Const WB As String = "C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx"
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim rng1 As Range
Set rng1 = Selection.Cells(1) 'in case of >1 cell selected
Set wbTarget = Workbooks.Open(WB)
Set wsTarget = wbTarget.Worksheets(rng1.Parent.Name)
rng1.Copy wsTarget.Range("E5")
rng1.Offset(0, 1).Copy wsTarget.Range("G5")
rng1.Offset(0, 2).Copy wsTarget.Range("I5")
rng1.Offset(0, 3).Copy wsTarget.Range("K5")
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
End Sub
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws
Below is the code I have tried with but it only worked for Column A, I want to do the same job with other columns:
Sub ColumnAMaster()
Dim lastRow As Long, lastRowMaster As Long
Dim ws As Worksheet
Dim Master As Worksheet
Application.ScreenUpdating = False
Set Master = Sheets.Add
Master.Name = "Master"
lastRowMaster = 1
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Master" Then
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1:A" & lastRow).Copy Destination:=Master.Range("A" & lastRowMaster)
lastRowMaster = Master.Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
sub Master_data()
'declarations
Dim ws1 as worksheet
Dim ws2 as worksheet
Dim ws3 as worksheet
Dim ws4 as worksheet
Dim i as long
Dim lastrow_sh1 as long
Dim lastrow_sh4 as long
Dim wb as workbook
set wb= application.activeworkbook
set ws1=wb.sheets("sheet1")
set ws2=wb.sheets("sheet2")
set ws3=wb.sheets("sheet3")
set ws4=wb.sheets("sheet4")
lastrow_sh1= ws1.range("A1").end(xlup).row
ws4.cells(1,1)="name"
for i =2 to lastrow_sh1
if ws1.cells(i,1)=ws2.cells(i,1) & ws3.cell(i,1)then
lastrow_sh4=ws4.range(A1).end(xlup).row
ws4.cells(lastrow_sh4+1,1)=ws1.cells(i,1)
ws4.cells(lastrow_sh4+1,2)=ws1.cells(i,2)
ws4.cells(lastrow_sh4+1,3)=ws1.cells(i,3)
ws4.cells(lastrow_sh4+1,4)=ws3.cells(i,4)
endif
next i
end sub